DPMJET/dpmjet3.0-5F.f

   1 *$ CREATE DT_INIT.FOR
   2 *COPY DT_INIT
   3 *
   4 *    +-------------------------------------------------------------+
   5 *    |                                                             |
   6 *    |                                                             |
   7 *    |                        DPMJET 3.0                           |
   8 *    |                                                             |
   9 *    |                                                             |
  10 *    |         S. Roesler+), R. Engel#), J. Ranft*)                |
  11 *    |                                                             |
  12 *    |         +) CERN, SC-RP                                      |
  13 *    |            CH-1211 Geneva 23, Switzerland                   |
  14 *    |            Email: Stefan.Roesler@cern.ch                    |
  15 *    |                                                             |
  16 *    |         #) Institut fuer Kernphysik                         |
  17 *    |            Forschungszentrum Karlsruhe                      |
  18 *    |            D-76021 Karlsruhe, Germany                       |
  19 *    |                                                             |
  20 *    |         *) University of Siegen, Dept. of Physics           |
  21 *    |            D-57068 Siegen, Germany                          |
  22 *    |                                                             |
  23 *    |                                                             |
  24 *    |       http://home.cern.ch/sroesler/dpmjet3.html             |
  25 *    |                                                             |
  26 *    |                                                             |
  27 *    |       Monte Carlo models used for event generation:         |
  28 *    |          PHOJET 1.12, JETSET 7.4 and LEPTO 6.5.1            |
  29 *    |                                                             |
  30 *    +-------------------------------------------------------------+
  31 *
  32 *
  33 *===init===============================================================*
  34 *
  35       SUBROUTINE DT_INIT(NCASES,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
  36      &                                             IDP,IGLAU)
  37
  38 ************************************************************************
  39 * Initialization of event generation                                   *
  40 * This version dated  7.4.98  is written by S. Roesler.                *
  41 *                                                                      *
  42 * Last change 27.12.2006 by S. Roesler.                                *
  43 ************************************************************************
  44
  45       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
  46       SAVE
  47
  48       PARAMETER ( LINP = 10 ,
  49      &            LOUT = 6 ,
  50      &            LDAT = 9 )
  51       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
  52
  53 * particle properties (BAMJET index convention)
  54       CHARACTER*8  ANAME
  55       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
  56      &                IICH(210),IIBAR(210),K1(210),K2(210)
  57
  58 * names of hadrons used in input-cards
  59       CHARACTER*8 BTYPE
  60       COMMON /DTPAIN/ BTYPE(30)
  61
  62 *      INCLUDE '(DIMPAR)'
  63 *     DIMPAR taken from FLUKA
  64       PARAMETER ( MXXRGN =20000 )
  65       PARAMETER ( MXXMDF =  710 )
  66       PARAMETER ( MXXMDE =  702 )
  67       PARAMETER ( MFSTCK =40000 )
  68       PARAMETER ( MESTCK =  100 )
  69       PARAMETER ( MOSTCK = 2000 )
  70       PARAMETER ( MXPRSN =  100 )
  71       PARAMETER ( MXPDPM =  800 )
  72       PARAMETER ( MXPSCS =30000 )
  73       PARAMETER ( MXGLWN =  300 )
  74       PARAMETER ( MXOUTU =   50 )
  75       PARAMETER ( NALLWP =   64 )
  76       PARAMETER ( NELEMX =   80 )
  77       PARAMETER ( MPDPDX =   18 )
  78       PARAMETER ( MXHTTR =  260 )
  79       PARAMETER ( MXSEAX =   20 )
  80       PARAMETER ( MXHTNC = MXSEAX + 1 )
  81       PARAMETER ( ICOMAX = 2400 )
  82       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
  83       PARAMETER ( NSTBIS =  304 )
  84       PARAMETER ( NQSTIS =   46 )
  85       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
  86       PARAMETER ( MXPABL =  120 )
  87       PARAMETER ( IDMAXP =  450 )
  88       PARAMETER ( IDMXDC = 2000 )
  89       PARAMETER ( MXMCIN =  410 )
  90       PARAMETER ( IHYPMX =    4 )
  91       PARAMETER ( MKBMX1 =   11 )
  92       PARAMETER ( MKBMX2 =   11 )
  93       PARAMETER ( MXIRRD = 2500 )
  94       PARAMETER ( MXTRDC = 1500 )
  95       PARAMETER ( NKTL   =   17 )
  96       PARAMETER ( NBLNMX = 40000000 )
  97
  98 *      INCLUDE '(PAREVT)'
  99 *     PAREVT taken from FLUKA
 100       PARAMETER ( FRDIFF = 0.2D+00 )
 101       PARAMETER ( ETHSEA = 1.0D+00 )
 102 *
 103       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
 104      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
 105      &        LNUCRI, LPEANU, LEVBME, LPHDRC, LATMSS, LISMRS, LCHDCY,
 106      &        LCHDCR, LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
 107       COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
 108      &                  LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
 109      &                  LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
 110      &                  LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LEVBME,
 111      &                  LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR,
 112      &                  LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
 113
 114 *      INCLUDE '(EVAFLG)'
 115 *     EVAFLG taken from FLUKA
 116       LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
 117      &        LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
 118      &        LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
 119      &        LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP, LEEXLV, LGEXLV
 120       COMMON / EVAFLG /     BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
 121      &        FDSCST,
 122      &        ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
 123      &        MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
 124      &        MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
 125      &        LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
 126      &        LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
 127      &        LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
 128      &        LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP, LEEXLV, LGEXLV
 129
 130 *      INCLUDE '(FRBKCM)'
 131 *     FRBKCM taken from FLUKA
 132 *  Maximum number of fragments to be emitted:
 133       PARAMETER ( MXFFBK =     6 )
 134       PARAMETER ( MXZFBK =    10 )
 135       PARAMETER ( MXNFBK =    12 )
 136       PARAMETER ( MXAFBK =    16 )
 137       PARAMETER ( MXASST =    25 )
 138       PARAMETER ( NXAFBK = MXAFBK + 1 )
 139       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
 140       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
 141       PARAMETER ( MXPSST =   700 )
 142 *  Maximum number of pre-computed break-up combinations
 143       PARAMETER ( MXPPFB = 42500 )
 144 *  Maximum number of break-up combinations, including special
 145 *  run-time ones:
 146       PARAMETER ( MXPSFB = 43000 )
 147 *  Base for J multiplicity encoding:
 148       PARAMETER ( IBFRBK =    73 )
 149 *  Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
 150 *  it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
 151 *  ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
 152 *  --> Ibfrbk^(Jpwfbx+1) < 2100000000
 153       PARAMETER ( JPWFBX =     4 )
 154       LOGICAL LFRMBK, LNCMSS
 155       COMMON / FRBKCM /  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
 156      &          WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
 157      &          SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
 158      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
 159      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
 160      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
 161      &          IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
 162      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
 163      &          IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
 164      &          IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
 165       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
 166
 167 * emulsion treatment
 168       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
 169      &                NCOMPO,IEMUL
 170
 171 * Glauber formalism: parameters
 172       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
 173      &                BMAX(NCOMPX),BSTEP(NCOMPX),
 174      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
 175      &                NSITEB,NSTATB
 176
 177 * Glauber formalism: cross sections
 178       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
 179      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
 180      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
 181      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
 182      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
 183      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
 184      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
 185      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
 186      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
 187      &                BSLOPE,NEBINI,NQBINI
 188
 189 * interface HADRIN-DPM
 190       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
 191
 192 * central particle production, impact parameter biasing
 193       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
 194
 195 * parameter for intranuclear cascade
 196       LOGICAL LPAULI
 197       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
 198
 199 * various options for treatment of partons (DTUNUC 1.x)
 200 * (chain recombination, Cronin,..)
 201       LOGICAL LCO2CR,LINTPT
 202       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
 203      &                LCO2CR,LINTPT
 204
 205 * threshold values for x-sampling (DTUNUC 1.x)
 206       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
 207      &                SSMIMQ,VVMTHR
 208
 209 * flags for input different options
 210       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
 211       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
 212      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
 213
 214 * nuclear potential
 215       LOGICAL LFERMI
 216       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
 217      &                EBINDP(2),EBINDN(2),EPOT(2,210),
 218      &                ETACOU(2),ICOUL,LFERMI
 219
 220 * n-n cross section fluctuations
 221       PARAMETER (NBINS = 1000)
 222       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
 223
 224 * flags for particle decays
 225       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
 226      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
 227      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
 228
 229 * diquark-breaking mechanism
 230       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
 231
 232 * nucleon-nucleon event-generator
 233       CHARACTER*8 CMODEL
 234       LOGICAL LPHOIN
 235       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
 236
 237 * properties of interacting particles
 238       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
 239
 240 * properties of photon/lepton projectiles
 241       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
 242
 243 * flags for diffractive interactions (DTUNUC 1.x)
 244       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
 245
 246 * parameters for hA-diffraction
 247       COMMON /DTDIHA/ DIBETA,DIALPH
 248
 249 * Lorentz-parameters of the current interaction
 250       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
 251      &                UMO,PPCM,EPROJ,PPROJ
 252
 253 * kinematical cuts for lepton-nucleus interactions
 254       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
 255      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
 256
 257 * VDM parameter for photon-nucleus interactions
 258       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
 259
 260 * Glauber formalism: flags and parameters for statistics
 261       LOGICAL LPROD
 262       CHARACTER*8 CGLB
 263       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
 264
 265 * cuts for variable energy runs
 266       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
 267
 268 * flags for activated histograms
 269       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
 270
 271       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
 272       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
 273
 274 * LEPTO
 275 **LUND single / double precision
 276       REAL CUT,PARL,TMPX,TMPY,TMPW2,TMPQ2,TMPU
 277       COMMON /LEPTOU/ CUT(14),LST(40),PARL(30),
 278      &                TMPX,TMPY,TMPW2,TMPQ2,TMPU
 279
 280 * LEPTO
 281       REAL RPPN
 282       COMMON /LEPTOI/ RPPN,LEPIN,INTER
 283
 284 * steering flags for qel neutrino scattering modules
 285       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
 286
 287 * event flag
 288       COMMON /DTEVNO/ NEVENT,ICASCA
 289
 290       INTEGER PYCOMP
 291
 292 C     DIMENSION XPARA(5)
 293       DIMENSION XDUMB(40),IPRANG(5)
 294
 295       PARAMETER (MXCARD=58)
 296       CHARACTER*78 CLINE,CTITLE
 297       CHARACTER*60 CWHAT
 298       CHARACTER*8  BLANK,SDUM
 299       CHARACTER*10 CODE,CODEWD
 300       CHARACTER*72 HEADER
 301       LOGICAL LSTART,LEINP,LXSTAB
 302       DIMENSION WHAT(6),CODE(MXCARD)
 303       DATA CODE/
 304      &   'TITLE     ','PROJPAR   ','TARPAR    ','ENERGY    ',
 305      &   'MOMENTUM  ','CMENERGY  ','EMULSION  ','FERMI     ',
 306      &   'TAUFOR    ','PAULI     ','COULOMB   ','HADRIN    ',
 307      &   'EVAP      ','EMCCHECK  ','MODEL     ','PHOINPUT  ',
 308      &   'GLAUBERI  ','FLUCTUAT  ','CENTRAL   ','RECOMBIN  ',
 309      &   'COMBIJET  ','XCUTS     ','INTPT     ','CRONINPT  ',
 310      &   'SEADISTR  ','SEASU3    ','DIQUARKS  ','RESONANC  ',
 311      &   'DIFFRACT  ','SINGLECH  ','NOFRAGME  ','HADRONIZE ',
 312      &   'POPCORN   ','PARDECAY  ','BEAM      ','LUND-MSTU ',
 313      &   'LUND-MSTJ ','LUND-MDCY ','LUND-PARJ ','LUND-PARU ',
 314      &   'OUTLEVEL  ','FRAME     ','L-TAG     ','L-ETAG    ',
 315      &   'ECMS-CUT  ','VDM-PAR1  ','HISTOGRAM ','XS-TABLE  ',
 316      &   'GLAUB-PAR ','GLAUB-INI ','VDM-PAR2  ','XS-QELPRO ',
 317      &   'RNDMINIT  ','LEPTO-CUT ','LEPTO-LST ','LEPTO-PARL',
 318      &   'START     ','STOP      '/
 319       DATA BLANK /'        '/
 320
 321       DATA LSTART,LXSTAB,IFIRST /.TRUE.,.FALSE.,1/
 322       DATA CMEOLD /0.0D0/
 323
 324 *---------------------------------------------------------------------
 325 * at the first call of INIT: initialize event generation
 326       EPNSAV = EPN
 327       IF (LSTART) THEN
 328          CALL DT_TITLE
 329 *   initialization and test of the random number generator
 330          IF (ITRSPT.NE.1) THEN
 331
 332             IJKLIN = -1
 333             INSEED = 1
 334             ISEED1 = 0
 335             ISEED2 = 0
 336             CALL RNINIT (INSEED,IJKLIN,ISEED1,ISEED2)
 337
 338          ENDIF
 339 *   initialization of BAMJET, DECAY and HADRIN
 340          CALL DT_DDATAR
 341          CALL DT_DHADDE
 342          CALL DT_DCHANT
 343          CALL DT_DCHANH
 344 *   set default values for input variables
 345          CALL DT_DEFAUL(EPN,PPN)
 346          IGLAU  = 0
 347          IXSQEL = 0
 348 *   flag for collision energy input
 349          LEINP  = .FALSE.
 350          LSTART = .FALSE.
 351       ENDIF
 352
 353 *---------------------------------------------------------------------
 354    10 CONTINUE
 355
 356 * bypass reading input cards (e.g. for use with Fluka)
 357 *  in this case Epn is expected to carry the beam momentum
 358       IF (NCASES.EQ.-1) THEN
 359          IP      = NPMASS
 360          IPZ     = NPCHAR
 361          PPN     = EPNSAV
 362          EPN     = ZERO
 363          CMENER  = ZERO
 364          LEINP   = .TRUE.
 365          MKCRON  = 0
 366          WHAT(1) = 1
 367          WHAT(2) = 0
 368          CODEWD  = 'START     '
 369          GOTO 900
 370       ENDIF
 371
 372 * read control card from input-unit LINP
 373       READ(LINP,'(A78)',END=9999) CLINE
 374       IF (CLINE(1:1).EQ.'*') THEN
 375 * comment-line
 376          WRITE(LOUT,'(A78)') CLINE
 377          GOTO 10
 378       ENDIF
 379 C     READ(CLINE,1000,END=9999) CODEWD,(WHAT(I),I=1,6),SDUM
 380 C1000 FORMAT(A10,6E10.0,A8)
 381       DO 1008 I=1,6
 382          WHAT(I) = ZERO
 383  1008 CONTINUE
 384       READ(CLINE,1006,END=9999) CODEWD,CWHAT,SDUM
 385  1006 FORMAT(A10,A60,A8)
 386       READ(CWHAT,*,END=1007) (WHAT(I),I=1,6)
 387  1007 CONTINUE
 388       WRITE(LOUT,1001) CODEWD,(WHAT(I),I=1,6),SDUM
 389  1001 FORMAT(A10,6G10.3,A8)
 390
 391   900 CONTINUE
 392
 393 * check for valid control card and get card index
 394       ICW = 0
 395       DO 11 I=1,MXCARD
 396          IF (CODEWD.EQ.CODE(I)) ICW = I
 397    11 CONTINUE
 398       IF (ICW.EQ.0) THEN
 399          WRITE(LOUT,1002) CODEWD
 400  1002    FORMAT(/,1X,'---> ',A10,': invalid control-card !',/)
 401          GOTO 10
 402       ENDIF
 403
 404       GOTO(
 405 *------------------------------------------------------------
 406 *       TITLE   ,  PROJPAR ,  TARPAR  ,  ENERGY  ,  MOMENTUM,
 407      &  100     ,  110     ,  120     ,  130     ,  140     ,
 408 *
 409 *------------------------------------------------------------
 410 *       CMENERGY,  EMULSION,  FERMI   ,  TAUFOR  ,  PAULI   ,
 411      &  150     ,  160     ,  170     ,  180     ,  190     ,
 412 *
 413 *------------------------------------------------------------
 414 *       COULOMB ,  HADRIN  ,  EVAP    ,  EMCCHECK,  MODEL   ,
 415      &  200     ,  210     ,  220     ,  230     ,  240     ,
 416 *
 417 *------------------------------------------------------------
 418 *       PHOINPUT,  GLAUBERI,  FLUCTUAT,  CENTRAL ,  RECOMBIN,
 419      &  250     ,  260     ,  270     ,  280     ,  290     ,
 420 *
 421 *------------------------------------------------------------
 422 *       COMBIJET,  XCUTS   ,  INTPT   ,  CRONINPT,  SEADISTR,
 423      &  300     ,  310     ,  320     ,  330     ,  340     ,
 424 *
 425 *------------------------------------------------------------
 426 *       SEASU3  ,  DIQUARKS,  RESONANC,  DIFFRACT,  SINGLECH,
 427      &  350     ,  360     ,  370     ,  380     ,  390     ,
 428 *
 429 *------------------------------------------------------------
 430 *       NOFRAGME, HADRONIZE,  POPCORN ,  PARDECAY,  BEAM    ,
 431      &  400     ,  410     ,  420     ,  430     ,  440     ,
 432 *
 433 *------------------------------------------------------------
 434 *      LUND-MSTU, LUND-MSTJ, LUND-MDCY, LUND-PARJ, LUND-PARU,
 435      &  450     ,  451     ,  452     ,  460     ,  470     ,
 436 *
 437 *------------------------------------------------------------
 438 *       OUTLEVEL,  FRAME   , L-TAG    ,  L-ETAG  ,  ECMS-CUT,
 439      &  480     ,  490     ,  500     ,  510     ,  520     ,
 440 *
 441 *------------------------------------------------------------
 442 *       VDM-PAR1, HISTOGRAM, XS-TABLE , GLAUB-PAR, GLAUB-INI,
 443      &  530     ,  540     ,  550     ,  560     ,  565     ,
 444 *
 445 *------------------------------------------------------------
 446 *               ,          ,  VDM-PAR2, XS-QELPRO, RNDMINIT ,
 447      &                        570     ,  580     ,  590     ,
 448 *
 449 *------------------------------------------------------------
 450 *      LEPTO-CUT, LEPTO-LST,LEPTO-PARL,  START   ,  STOP    )
 451      &  600     ,  610     ,  620     ,  630     ,  640     ) , ICW
 452 *
 453 *------------------------------------------------------------
 454
 455       GOTO 10
 456
 457 *********************************************************************
 458 *                                                                   *
 459 *               control card:  codewd = TITLE                       *
 460 *                                                                   *
 461 *       what (1..6), sdum   no meaning                              *
 462 *                                                                   *
 463 *       Note:  The control-card following this must consist of      *
 464 *              a string of characters usually giving the title of   *
 465 *              the run.                                             *
 466 *                                                                   *
 467 *********************************************************************
 468
 469   100 CONTINUE
 470       READ(LINP,'(A78)') CTITLE
 471       WRITE(LOUT,'(//,5X,A78,//)') CTITLE
 472       GOTO 10
 473
 474 *********************************************************************
 475 *                                                                   *
 476 *               control card:  codewd = PROJPAR                     *
 477 *                                                                   *
 478 *       what (1) =  mass number of projectile nucleus  default: 1   *
 479 *       what (2) =  charge of projectile nucleus       default: 1   *
 480 *       what (3..6)   no meaning                                    *
 481 *       sdum        projectile particle code word                   *
 482 *                                                                   *
 483 *       Note: If sdum is defined what (1..2) have no meaning.       *
 484 *                                                                   *
 485 *********************************************************************
 486
 487   110 CONTINUE
 488       IF (SDUM.EQ.BLANK) THEN
 489          IP     = INT(WHAT(1))
 490          IPZ    = INT(WHAT(2))
 491          IJPROJ = 1
 492          IBPROJ = 1
 493       ELSE
 494          IJPROJ = 0
 495          DO 111 II=1,30
 496             IF (SDUM.EQ.BTYPE(II)) THEN
 497                IP     = 1
 498                IPZ    = 1
 499                IF (II.EQ.26) THEN
 500                   IJPROJ = 135
 501                ELSEIF (II.EQ.27) THEN
 502                   IJPROJ = 136
 503                ELSEIF (II.EQ.28) THEN
 504                   IJPROJ = 133
 505                ELSEIF (II.EQ.29) THEN
 506                   IJPROJ = 134
 507                ELSE
 508                   IJPROJ = II
 509                ENDIF
 510                IBPROJ = IIBAR(IJPROJ)
 511 * photon
 512                IF ((IJPROJ.EQ.7).AND.(WHAT(1).GT.ZERO)) VIRT = WHAT(1)
 513 * lepton
 514                IF (((IJPROJ.EQ. 3).OR.(IJPROJ.EQ. 4).OR.
 515      &              (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11)).AND.
 516      &                              (WHAT(1).GT.ZERO)) Q2HI = WHAT(1)
 517             ENDIF
 518   111    CONTINUE
 519          IF (IJPROJ.EQ.0) THEN
 520             WRITE(LOUT,1110)
 521  1110       FORMAT(/,1X,'invalid PROJPAR card !',/)
 522             GOTO 9999
 523          ENDIF
 524       ENDIF
 525       GOTO 10
 526
 527 *********************************************************************
 528 *                                                                   *
 529 *               control card:  codewd = TARPAR                      *
 530 *                                                                   *
 531 *       what (1) =  mass number of target nucleus      default: 1   *
 532 *       what (2) =  charge of target nucleus           default: 1   *
 533 *       what (3..6)   no meaning                                    *
 534 *       sdum        target particle code word                       *
 535 *                                                                   *
 536 *       Note: If sdum is defined what (1..2) have no meaning.       *
 537 *                                                                   *
 538 *********************************************************************
 539
 540   120 CONTINUE
 541       IF (SDUM.EQ.BLANK) THEN
 542          IT     = INT(WHAT(1))
 543          ITZ    = INT(WHAT(2))
 544          IJTARG = 1
 545          IBTARG = 1
 546       ELSE
 547          IJTARG = 0
 548          DO 121 II=1,30
 549             IF (SDUM.EQ.BTYPE(II)) THEN
 550                IT     = 1
 551                ITZ    = 1
 552                IJTARG = II
 553                IBTARG = IIBAR(IJTARG)
 554             ENDIF
 555   121    CONTINUE
 556          IF (IJTARG.EQ.0) THEN
 557             WRITE(LOUT,1120)
 558  1120       FORMAT(/,1X,'invalid TARPAR card !',/)
 559             GOTO 9999
 560          ENDIF
 561       ENDIF
 562       GOTO 10
 563
 564 *********************************************************************
 565 *                                                                   *
 566 *               control card:  codewd = ENERGY                      *
 567 *                                                                   *
 568 *       what (1) =  energy (GeV) of projectile in Lab.              *
 569 *                   if what(1) < 0:  |what(1)| = kinetic energy     *
 570 *                                                default: 200 GeV   *
 571 *                   if |what(2)| > 0: min. energy for variable      *
 572 *                                     energy runs                   *
 573 *       what (2) =  max. energy for variable energy runs            *
 574 *                   if what(2) < 0:  |what(2)| = kinetic energy     *
 575 *                                                                   *
 576 *********************************************************************
 577
 578   130 CONTINUE
 579       EPN    = WHAT(1)
 580       PPN    = ZERO
 581       CMENER = ZERO
 582       IF ((ABS(WHAT(2)).GT.ZERO).AND.
 583      &    (ABS(WHAT(2)).GT.ABS(WHAT(1)))) THEN
 584          VARELO = WHAT(1)
 585          VAREHI = WHAT(2)
 586          EPN    = VAREHI
 587       ENDIF
 588       LEINP  = .TRUE.
 589       GOTO 10
 590
 591 *********************************************************************
 592 *                                                                   *
 593 *               control card:  codewd = MOMENTUM                    *
 594 *                                                                   *
 595 *       what (1) =  momentum (GeV/c) of projectile in Lab.          *
 596 *                                                default: 200 GeV/c *
 597 *       what (2..6), sdum   no meaning                              *
 598 *                                                                   *
 599 *********************************************************************
 600
 601   140 CONTINUE
 602       EPN    = ZERO
 603       PPN    = WHAT(1)
 604       CMENER = ZERO
 605       LEINP  = .TRUE.
 606       GOTO 10
 607
 608 *********************************************************************
 609 *                                                                   *
 610 *               control card:  codewd = CMENERGY                    *
 611 *                                                                   *
 612 *       what (1) =  energy in nucleon-nucleon cms.                  *
 613 *                                                default: none      *
 614 *       what (2..6), sdum   no meaning                              *
 615 *                                                                   *
 616 *********************************************************************
 617
 618   150 CONTINUE
 619       EPN    = ZERO
 620       PPN    = ZERO
 621       CMENER = WHAT(1)
 622       LEINP  = .TRUE.
 623       GOTO 10
 624
 625 *********************************************************************
 626 *                                                                   *
 627 *               control card:  codewd = EMULSION                    *
 628 *                                                                   *
 629 *               definition of nuclear emulsions                     *
 630 *                                                                   *
 631 *     what(1)      mass number of emulsion component                *
 632 *     what(2)      charge of emulsion component                     *
 633 *     what(3)      fraction of events in which a scattering on a    *
 634 *                  nucleus of this properties is performed          *
 635 *     what(4,5,6)  as what(1,2,3) but for another component         *
 636 *                                             default: no emulsion  *
 637 *     sdum         no meaning                                       *
 638 *                                                                   *
 639 *     Note: If this input-card is once used with valid parameters   *
 640 *           TARPAR is obsolete.                                     *
 641 *           Not the absolute values of the fractions are important  *
 642 *           but only the ratios of fractions of different comp.     *
 643 *           This control card can be repeatedly used to define      *
 644 *           emulsions consisting of up to 10 elements.              *
 645 *                                                                   *
 646 *********************************************************************
 647
 648   160 CONTINUE
 649       IF ((WHAT(1).GT.ZERO).AND.(WHAT(2).GT.ZERO)
 650      &                     .AND.(ABS(WHAT(3)).GT.ZERO)) THEN
 651          NCOMPO = NCOMPO+1
 652          IF (NCOMPO.GT.NCOMPX) THEN
 653             WRITE(LOUT,1600)
 654             STOP
 655          ENDIF
 656          IEMUMA(NCOMPO) = INT(WHAT(1))
 657          IEMUCH(NCOMPO) = INT(WHAT(2))
 658          EMUFRA(NCOMPO) = WHAT(3)
 659          IEMUL = 1
 660 C        CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
 661       ENDIF
 662       IF ((WHAT(4).GT.ZERO).AND.(WHAT(5).GT.ZERO)
 663      &                     .AND.(ABS(WHAT(6)).GT.ZERO)) THEN
 664          NCOMPO = NCOMPO+1
 665          IF (NCOMPO.GT.NCOMPX) THEN
 666             WRITE(LOUT,1001)
 667             STOP
 668          ENDIF
 669          IEMUMA(NCOMPO) = INT(WHAT(4))
 670          IEMUCH(NCOMPO) = INT(WHAT(5))
 671          EMUFRA(NCOMPO) = WHAT(6)
 672 C        CALL SHMAKF(IDUM,IDUM,IEMUMA(NCOMPO),IEMUCH(NCOMPO))
 673       ENDIF
 674  1600 FORMAT(1X,'too many emulsion components - program stopped')
 675       GOTO 10
 676
 677 *********************************************************************
 678 *                                                                   *
 679 *               control card:  codewd = FERMI                       *
 680 *                                                                   *
 681 *       what (1) = -1 Fermi-motion of nucleons not treated          *
 682 *                                                 default: 1        *
 683 *       what (2) =    scale factor for Fermi-momentum               *
 684 *                                                 default: 0.75     *
 685 *       what (3..6), sdum   no meaning                              *
 686 *                                                                   *
 687 *********************************************************************
 688
 689   170 CONTINUE
 690       IF (WHAT(1).EQ.-1.0D0) THEN
 691          LFERMI = .FALSE.
 692       ELSE
 693          LFERMI = .TRUE.
 694       ENDIF
 695       XMOD = WHAT(2)
 696       IF (XMOD.GE.ZERO) FERMOD = XMOD
 697       GOTO 10
 698
 699 *********************************************************************
 700 *                                                                   *
 701 *               control card:  codewd = TAUFOR                      *
 702 *                                                                   *
 703 *          formation time supressed intranuclear cascade            *
 704 *                                                                   *
 705 *    what (1)      formation time (in fm/c)                         *
 706 *                  note: what(1)=10. corresponds roughly to an      *
 707 *                        average formation time of 1 fm/c           *
 708 *                                                 default: 5. fm/c  *
 709 *    what (2)      number of generations followed                   *
 710 *                                                 default: 25       *
 711 *    what (3) = 1. p_t-dependent formation zone                     *
 712 *             = 2. constant formation zone                          *
 713 *                                                 default: 1        *
 714 *    what (4)      modus of selection of nucleus where the          *
 715 *                  cascade if followed first                        *
 716 *             = 1.  proj./target-nucleus with probab. 1/2           *
 717 *             = 2.  nucleus with highest mass                       *
 718 *             = 3.  proj. nucleus if particle is moving in pos. z   *
 719 *                   targ. nucleus if particle is moving in neg. z   *
 720 *                                                 default: 1        *
 721 *    what (5..6), sdum   no meaning                                 *
 722 *                                                                   *
 723 *********************************************************************
 724
 725   180 CONTINUE
 726       TAUFOR = WHAT(1)
 727       KTAUGE = INT(WHAT(2))
 728       INCMOD = 1
 729       IF ((WHAT(3).GE.1.0D0).AND.(WHAT(3).LE.2.0D0))
 730      &                                    ITAUVE = INT(WHAT(3))
 731       IF ((WHAT(4).GE.1.0D0).AND.(WHAT(4).LE.3.0D0))
 732      &                                    INCMOD = INT(WHAT(4))
 733       GOTO 10
 734
 735 *********************************************************************
 736 *                                                                   *
 737 *               control card:  codewd = PAULI                       *
 738 *                                                                   *
 739 *       what (1) =  -1  Pauli's principle for secondary             *
 740 *                       interactions not treated                    *
 741 *                                                    default: 1     *
 742 *       what (2..6), sdum   no meaning                              *
 743 *                                                                   *
 744 *********************************************************************
 745
 746   190 CONTINUE
 747       IF (WHAT(1).EQ.-1.0D0) THEN
 748          LPAULI = .FALSE.
 749       ELSE
 750          LPAULI = .TRUE.
 751       ENDIF
 752       GOTO 10
 753
 754 *********************************************************************
 755 *                                                                   *
 756 *               control card:  codewd = COULOMB                     *
 757 *                                                                   *
 758 *       what (1) = -1. Coulomb-energy treatment switched off        *
 759 *                                                    default: 1     *
 760 *       what (2..6), sdum   no meaning                              *
 761 *                                                                   *
 762 *********************************************************************
 763
 764   200 CONTINUE
 765       ICOUL = 1
 766       IF (WHAT(1).EQ.-1.0D0) THEN
 767          ICOUL = 0
 768       ELSE
 769          ICOUL = 1
 770       ENDIF
 771       GOTO 10
 772
 773 *********************************************************************
 774 *                                                                   *
 775 *               control card:  codewd = HADRIN                      *
 776 *                                                                   *
 777 *                       HADRIN module                               *
 778 *                                                                   *
 779 *    what (1) = 0. elastic/inelastic interactions with probab.      *
 780 *                  as defined by cross-sections                     *
 781 *             = 1. inelastic interactions forced                    *
 782 *             = 2. elastic interactions forced                      *
 783 *                                                 default: 1        *
 784 *    what (2)      upper threshold in total energy (GeV) below      *
 785 *                  which interactions are sampled by HADRIN         *
 786 *                                                 default: 5. GeV   *
 787 *    what (3..6), sdum   no meaning                                 *
 788 *                                                                   *
 789 *********************************************************************
 790
 791   210 CONTINUE
 792       IWHAT = INT(WHAT(1))
 793       IF ((IWHAT.GE.0).AND.(IWHAT.LE.2)) INTHAD = IWHAT
 794       IF ((WHAT(2).GT.ZERO).AND.(WHAT(2).LT.15.0D0)) EHADTH = WHAT(2)
 795       GOTO 10
 796
 797 *********************************************************************
 798 *                                                                   *
 799 *               control card:  codewd = EVAP                        *
 800 *                                                                   *
 801 *                    evaporation module                             *
 802 *                                                                   *
 803 *  what (1) =< -1 ==> evaporation is switched off                   *
 804 *           >=  1 ==> evaporation is performed                      *
 805 *                                                                   *
 806 *         what (1) = i1 + i2*10 + i3*100 + i4*10000                 *
 807 *                    (i1, i2, i3, i4 >= 0 )                         *
 808 *                                                                   *
 809 *   i1 is the flag for selecting the T=0 level density option used  *
 810 *      =  1: standard EVAP level densities with Cook pairing        *
 811 *            energies                                               *
 812 *      =  2: Z,N-dependent Gilbert & Cameron level densities        *
 813 *                                                        (default)  *
 814 *      =  3: Julich A-dependent level densities                     *
 815 *      =  4: Z,N-dependent Brancazio & Cameron level densities      *
 816 *                                                                   *
 817 *   i2 >= 1: high energy fission activated                          *
 818 *            (default high energy fission activated)                *
 819 *                                                                   *
 820 *   i3 =  0: No energy dependence for level densities               *
 821 *      =  1: Standard Ignyatuk (1975, 1st) energy dependence        *
 822 *            for level densities (default)                          *
 823 *      =  2: Standard Ignyatuk (1975, 1st) energy dependence        *
 824 *            for level densities with NOT used set of parameters    *
 825 *      =  3: Standard Ignyatuk (1975, 1st) energy dependence        *
 826 *            for level densities with NOT used set of parameters    *
 827 *      =  4: Second   Ignyatuk (1975, 2nd) energy dependence        *
 828 *            for level densities                                    *
 829 *      =  5: Second   Ignyatuk (1975, 2nd) energy dependence        *
 830 *            for level densities with fit 1 Iljinov & Mebel set of  *
 831 *            parameters                                             *
 832 *      =  6: Second   Ignyatuk (1975, 2nd) energy dependence        *
 833 *            for level densities with fit 2 Iljinov & Mebel set of  *
 834 *            parameters                                             *
 835 *      =  7: Second   Ignyatuk (1975, 2nd) energy dependence        *
 836 *            for level densities with fit 3 Iljinov & Mebel set of  *
 837 *            parameters                                             *
 838 *      =  8: Second   Ignyatuk (1975, 2nd) energy dependence        *
 839 *            for level densities with fit 4 Iljinov & Mebel set of  *
 840 *            parameters                                             *
 841 *                                                                   *
 842 *   i4 >= 1: Original Gilbert and Cameron pairing energies used     *
 843 *            (default Cook's modified pairing energies)             *
 844 *                                                                   *
 845 *  what (2) = ig + 10 * if   (ig and if must have the same sign)    *
 846 *                                                                   *
 847 *   ig =< -1 ==> deexcitation gammas are not produced               *
 848 *                (if the evaporation step is not performed          *
 849 *                 they are never produced)                          *
 850 *   if =< -1 ==> Fermi Break Up is not invoked                      *
 851 *                (if the evaporation step is not performed          *
 852 *                 it is never invoked)                              *
 853 *   The default is: deexcitation gamma produced and Fermi break up  *
 854 *                   activated for the new  preequilibrium, not      *
 855 *                   activated otherwise.                            *
 856 *  what (3..6), sdum   no meaning                                   *
 857 *                                                                   *
 858 *********************************************************************
 859
 860  220  CONTINUE
 861       IF (WHAT(1).LE.-1.0D0) THEN
 862          LEVPRT = .FALSE.
 863          LDEEXG = .FALSE.
 864          LHEAVY = .FALSE.
 865          GOTO 10
 866       ENDIF
 867       WHTSAV = WHAT (1)
 868       IF ( NINT (WHAT (1)) .GE. 10000 ) THEN
 869          LLVMOD   = .FALSE.
 870          JLVHLP   = NINT (WHAT (1)) / 10000
 871          WHAT (1) = WHAT (1) - 10000.D+00 * JLVHLP
 872       END IF
 873       IF ( NINT (WHAT (1)) .GE. 100 ) THEN
 874          JLVMOD   = NINT (WHAT (1)) / 100
 875          WHAT (1) = WHAT (1) - 100.D+00 * JLVMOD
 876       END IF
 877       IF ( NINT (WHAT (1)) .GE. 10  ) THEN
 878
 879          IEVFSS   = 1
 880
 881          JLVHLP   = NINT (WHAT (1)) / 10
 882          WHAT (1) = WHAT (1) - 10.D+00 * JLVHLP
 883       ELSE IF ( NINT (WHTSAV) .NE. 0 ) THEN
 884
 885          IEVFSS   = 0
 886
 887       END IF
 888       IF ( NINT (WHAT (1)) .GE. 0 ) THEN
 889          LEVPRT = .TRUE.
 890          ILVMOD = NINT (WHAT(1))
 891          IF ( ABS (NINT (WHAT (2))) .GE. 10  ) THEN
 892             LFRMBK   = .TRUE.
 893             JLVHLP   = NINT (WHAT (2)) / 10
 894             WHAT (2) = WHAT (2) - 10.D+00 * JLVHLP
 895          ELSE IF ( NINT (WHAT (2)) .NE. 0 ) THEN
 896             LFRMBK   = .FALSE.
 897          END IF
 898          IF ( NINT (WHAT (2)) .GE. 0 ) THEN
 899             LDEEXG = .TRUE.
 900          ELSE
 901             LDEEXG = .FALSE.
 902          END IF
 903 **sr heavies are always put to /FKFHVY/
 904 C        IF ( NINT (WHAT(3)) .GE. 1 ) THEN
 905 C           LHEAVY = .TRUE.
 906 C        ELSE
 907 C           LHEAVY = .FALSE.
 908 C        END IF
 909          LHEAVY = .TRUE.
 910       ELSE
 911          LEVPRT = .FALSE.
 912          LDEEXG = .FALSE.
 913          LHEAVY = .FALSE.
 914       END IF
 915
 916       LOLDEV = .FALSE.
 917
 918       GOTO 10
 919
 920 *********************************************************************
 921 *                                                                   *
 922 *               control card:  codewd = EMCCHECK                    *
 923 *                                                                   *
 924 *    extended energy-momentum / quantum-number conservation check   *
 925 *                                                                   *
 926 *       what (1) = -1   extended check not performed                *
 927 *                                                    default: 1.    *
 928 *       what (2..6), sdum   no meaning                              *
 929 *                                                                   *
 930 *********************************************************************
 931
 932   230 CONTINUE
 933       IF (WHAT(1).EQ.-1) THEN
 934          LEMCCK = .FALSE.
 935       ELSE
 936          LEMCCK = .TRUE.
 937       ENDIF
 938       GOTO 10
 939
 940 *********************************************************************
 941 *                                                                   *
 942 *               control card:  codewd = MODEL                       *
 943 *                                                                   *
 944 *     Model to be used to treat nucleon-nucleon interactions        *
 945 *                                                                   *
 946 *       sdum = DTUNUC    two-chain model                            *
 947 *            = PHOJET    multiple chains including minijets         *
 948 *            = LEPTO     DIS                                        *
 949 *            = QNEUTRIN  quasi-elastic neutrino scattering          *
 950 *                                                  default: PHOJET  *
 951 *                                                                   *
 952 *       if sdum = LEPTO:                                            *
 953 *       what (1)         (variable INTER)                           *
 954 *                        = 1  gamma exchange                        *
 955 *                        = 2  W+-   exchange                        *
 956 *                        = 3  Z0    exchange                        *
 957 *                        = 4  gamma/Z0 exchange                     *
 958 *                                                                   *
 959 *       if sdum = QNEUTRIN:                                         *
 960 *       what (1)         = 0  elastic scattering on nucleon and     *
 961 *                             tau does not decay (default)          *
 962 *                        = 1  decay of tau into mu..                *
 963 *                        = 2  decay of tau into e..                 *
 964 *                        = 10 CC events on p and n                  *
 965 *                        = 11 NC events on p and n                  *
 966 *                                                                   *
 967 *       what (2..6)      no meaning                                 *
 968 *                                                                   *
 969 *********************************************************************
 970
 971   240 CONTINUE
 972       IF (SDUM.EQ.CMODEL(1)) THEN
 973          MCGENE = 1
 974       ELSEIF (SDUM.EQ.CMODEL(2)) THEN
 975          MCGENE = 2
 976       ELSEIF (SDUM.EQ.CMODEL(3)) THEN
 977          MCGENE = 3
 978          IF ((WHAT(1).GE.1.0D0).AND.(WHAT(1).LE.4.0D0))
 979      &      INTER = INT(WHAT(1))
 980       ELSEIF (SDUM.EQ.CMODEL(4)) THEN
 981          MCGENE = 4
 982          IWHAT  = INT(WHAT(1))
 983          IF ((IWHAT.EQ.1 ).OR.(IWHAT.EQ.2 ).OR.
 984      &       (IWHAT.EQ.10).OR.(IWHAT.EQ.11))
 985      &      NEUDEC = IWHAT
 986       ELSE
 987          STOP ' Unknown model !'
 988       ENDIF
 989       GOTO 10
 990
 991 *********************************************************************
 992 *                                                                   *
 993 *               control card:  codewd = PHOINPUT                    *
 994 *                                                                   *
 995 *       Start of input-section for PHOJET-specific input-cards      *
 996 *       Note:  This section will not be finished before giving      *
 997 *              ENDINPUT-card                                        *
 998 *       what (1..6), sdum   no meaning                              *
 999 *                                                                   *
1000 *********************************************************************
1001
1002   250 CONTINUE
1003       IF (LPHOIN) THEN
1004
1005          CALL PHO_INIT(LINP,LOUT,IREJ1)
1006
1007          IF (IREJ1.NE.0) THEN
1008             WRITE(LOUT,'(1X,A)')'INIT:   reading PHOJET-input failed'
1009             STOP
1010          ENDIF
1011          LPHOIN = .FALSE.
1012       ENDIF
1013       GOTO 10
1014
1015 *********************************************************************
1016 *                                                                   *
1017 *               control card:  codewd = GLAUBERI                    *
1018 *                                                                   *
1019 *        Pre-initialization of impact parameter selection           *
1020 *                                                                   *
1021 *        what (1..6), sdum   no meaning                             *
1022 *                                                                   *
1023 *********************************************************************
1024
1025   260 CONTINUE
1026       IF (IFIRST.NE.99) THEN
1027          CALL DT_RNDMST(12,34,56,78)
1028          CALL DT_RNDMTE(1)
1029          OPEN(40,FILE='outdata0/shm.out',STATUS='UNKNOWN')
1030 C        OPEN(11,FILE='outdata0/shm.dbg',STATUS='UNKNOWN')
1031          IFIRST = 99
1032       ENDIF
1033
1034       IPPN = 8
1035       PLOW = 10.0D0
1036 C     IPPN = 1
1037 C     PLOW = 100.0D0
1038       PHI  = 1.0D5
1039       APLOW = LOG10(PLOW)
1040       APHI  = LOG10(PHI)
1041       ADP   = (APHI-APLOW)/DBLE(IPPN)
1042
1043       IPLOW = 1
1044       IDIP  = 1
1045       IIP   = 5
1046 C     IPLOW = 1
1047 C     IDIP  = 1
1048 C     IIP   = 1
1049       IPRANG(1) = 1
1050       IPRANG(2) = 2
1051       IPRANG(3) = 5
1052       IPRANG(4) = 10
1053       IPRANG(5) = 20
1054
1055       ITLOW = 30
1056       IDIT  = 3
1057       IIT   = 60
1058 C     IDIT  = 10
1059 C     IIT   = 21
1060
1061       DO 473 NCIT=1,IIT
1062          IT   = ITLOW+(NCIT-1)*IDIT
1063 C        IPHI = IT
1064 C        IDIP = 10
1065 C        IIP  = (IPHI-IPLOW)/IDIP
1066 C        IF (IIP.EQ.0) IIP = 1
1067 C        IF (IT.EQ.IPLOW) IIP = 0
1068
1069          DO 472 NCIP=1,IIP
1070             IP = IPRANG(NCIP)
1071 CC           IF (NCIP.LE.IIP) THEN
1072 C               IP = IPLOW+(NCIP-1)*IDIP
1073 CC           ELSE
1074 CC              IP = IT
1075 CC           ENDIF
1076             IF (IP.GT.IT) GOTO 472
1077
1078             DO 471 NCP=1,IPPN+1
1079                APPN = APLOW+DBLE(NCP-1)*ADP
1080                PPN  = 10**APPN
1081
1082                OPEN(12,FILE='outdata0/shm.sta',STATUS='UNKNOWN')
1083                WRITE(12,'(1X,2I5,E15.3)') IP,IT,PPN
1084                CLOSE(12)
1085
1086                XLIM1 = 0.0D0
1087                XLIM2 = 50.0D0
1088                XLIM3 = ZERO
1089                IBIN  = 50
1090                CALL DT_NEWHGR(XDUM,XDUM,XDUM,XDUMB,-1,IHDUM)
1091                CALL DT_NEWHGR(XLIM1,XLIM2,XLIM3,XDUMB,IBIN,IHSHMA)
1092
1093                NEVFIT = 5
1094 C              IF ((IP.GT.10).OR.(IT.GT.10)) THEN
1095 C                 NEVFIT = 5
1096 C              ELSE
1097 C                 NEVFIT = 10
1098 C              ENDIF
1099                SIGAV  = 0.0D0
1100
1101                DO 478 I=1,NEVFIT
1102                   CALL DT_SHMAKI(IP,IDUM1,IT,IDUM1,IJPROJ,PPN,99)
1103                   SIGAV = SIGAV+XSPRO(1,1,1)
1104                   DO 479 J=1,50
1105                      XC = DBLE(J)
1106                      CALL DT_FILHGR(XC,BSITE(1,1,1,J),IHSHMA,I)
1107   479             CONTINUE
1108   478          CONTINUE
1109
1110                CALL DT_EVTHIS(IDUM)
1111                HEADER = ' BSITE'
1112 C              CALL OUTGEN(IHSHMA,0,0,0,0,0,HEADER,0,NEVFIT,ONE,0,1,-1)
1113
1114 C              CALL GENFIT(XPARA)
1115 C              WRITE(40,'(2I4,E11.3,F6.0,5E11.3)')
1116 C    &              IP,IT,PPN,SIGAV/DBLE(NEVFIT),XPARA
1117
1118   471       CONTINUE
1119
1120   472    CONTINUE
1121
1122   473 CONTINUE
1123
1124       STOP
1125
1126 *********************************************************************
1127 *                                                                   *
1128 *               control card:  codewd = FLUCTUAT                    *
1129 *                                                                   *
1130 *           Treatment of cross section fluctuations                 *
1131 *                                                                   *
1132 *       what (1) = 1  treat cross section fluctuations              *
1133 *                                                    default: 0.    *
1134 *       what (1..6), sdum   no meaning                              *
1135 *                                                                   *
1136 *********************************************************************
1137
1138  270  CONTINUE
1139       IFLUCT = 0
1140       IF (WHAT(1).EQ.ONE) THEN
1141          IFLUCT = 1
1142          CALL DT_FLUINI
1143       ENDIF
1144       GOTO 10
1145
1146 *********************************************************************
1147 *                                                                   *
1148 *               control card:  codewd = CENTRAL                     *
1149 *                                                                   *
1150 *       what (1) = 1.  central production forced     default: 0     *
1151 *  if what (1) < 0 and > -100                                       *
1152 *       what (2) = min. impact parameter             default: 0     *
1153 *       what (3) = max. impact parameter             default: b_max *
1154 *  if what (1) < -99                                                *
1155 *       what (2) = fraction of cross section         default: 1     *
1156 *  if what (1) = -1 : evaporation/fzc suppressed                    *
1157 *  if what (1) < -1 : evaporation/fzc allowed                       *
1158 *                                                                   *
1159 *       what (4..6), sdum   no meaning                              *
1160 *                                                                   *
1161 *********************************************************************
1162
1163   280 CONTINUE
1164       ICENTR = INT(WHAT(1))
1165       IF (ICENTR.LT.0) THEN
1166          IF (ICENTR.GT.-100) THEN
1167             BIMIN = WHAT(2)
1168             BIMAX = WHAT(3)
1169          ELSE
1170             XSFRAC = WHAT(2)
1171          ENDIF
1172       ENDIF
1173       GOTO 10
1174
1175 *********************************************************************
1176 *                                                                   *
1177 *               control card:  codewd = RECOMBIN                    *
1178 *                                                                   *
1179 *                     Chain recombination                           *
1180 *        (recombine S-S and V-V chains to V-S chains)               *
1181 *                                                                   *
1182 *       what (1) = -1. recombination switched off    default: 1     *
1183 *       what (2..6), sdum   no meaning                              *
1184 *                                                                   *
1185 *********************************************************************
1186
1187   290 CONTINUE
1188       IRECOM = 1
1189       IF (WHAT(1).EQ.-1.0D0) IRECOM = 0
1190       GOTO 10
1191
1192 *********************************************************************
1193 *                                                                   *
1194 *               control card:  codewd = COMBIJET                    *
1195 *                                                                   *
1196 *               chain fusion (2 q-aq --> qq-aqaq)                   *
1197 *                                                                   *
1198 *       what (1) = 1   fusion treated                               *
1199 *                                                    default: 0.    *
1200 *       what (2)       minimum number of uncombined chains from     *
1201 *                      single projectile or target nucleons         *
1202 *                                                    default: 0.    *
1203 *       what (3..6), sdum   no meaning                              *
1204 *                                                                   *
1205 *********************************************************************
1206
1207   300 CONTINUE
1208       LCO2CR = .FALSE.
1209       IF (INT(WHAT(1)).EQ.1) LCO2CR = .TRUE.
1210       IF (WHAT(2).GE.ZERO) CUTOF = WHAT(2)
1211       GOTO 10
1212
1213 *********************************************************************
1214 *                                                                   *
1215 *               control card:  codewd = XCUTS                       *
1216 *                                                                   *
1217 *                 thresholds for x-sampling                         *
1218 *                                                                   *
1219 *    what (1)    defines lower threshold for val.-q x-value (CVQ)   *
1220 *                                                 default: 1.       *
1221 *    what (2)    defines lower threshold for val.-qq x-value (CDQ)  *
1222 *                                                 default: 2.       *
1223 *    what (3)    defines lower threshold for sea-q x-value (CSEA)   *
1224 *                                                 default: 0.2      *
1225 *    what (4)    sea-q x-values in S-S chains (SSMIMA)              *
1226 *                                                 default: 0.14     *
1227 *    what (5)    not used                                           *
1228 *                                                 default: 2.       *
1229 *    what (6), sdum   no meaning                                    *
1230 *                                                                   *
1231 *    Note: Lower thresholds (what(1..3)) are def. as x_thr=CXXX/ECM *
1232 *                                                                   *
1233 *********************************************************************
1234
1235   310 CONTINUE
1236       IF (WHAT(1).GE.0.5D0) CVQ    = WHAT(1)
1237       IF (WHAT(2).GE.ONE)   CDQ    = WHAT(2)
1238       IF (WHAT(3).GE.0.1D0) CSEA   = WHAT(3)
1239       IF (WHAT(4).GE.ZERO) THEN
1240          SSMIMA = WHAT(4)
1241          SSMIMQ = SSMIMA**2
1242       ENDIF
1243       IF (WHAT(5).GT.2.0D0) VVMTHR = WHAT(5)
1244       GOTO 10
1245
1246 *********************************************************************
1247 *                                                                   *
1248 *               control card:  codewd = INTPT                       *
1249 *                                                                   *
1250 *     what (1) = -1   intrinsic transverse momenta of partons       *
1251 *                     not treated                default: 1         *
1252 *     what (2..6), sdum   no meaning                                *
1253 *                                                                   *
1254 *********************************************************************
1255
1256   320 CONTINUE
1257       IF (WHAT(1).EQ.-1.0D0) THEN
1258          LINTPT = .FALSE.
1259       ELSE
1260          LINTPT = .TRUE.
1261       ENDIF
1262       GOTO 10
1263
1264 *********************************************************************
1265 *                                                                   *
1266 *               control card:  codewd = CRONINPT                    *
1267 *                                                                   *
1268 *    Cronin effect (multiple scattering of partons at chain ends)   *
1269 *                                                                   *
1270 *       what (1) = -1  Cronin effect not treated     default: 1     *
1271 *       what (2) = 0   scattering parameter          default: 0.64  *
1272 *       what (3..6), sdum   no meaning                              *
1273 *                                                                   *
1274 *********************************************************************
1275
1276   330 CONTINUE
1277       IF (WHAT(1).EQ.-1.0D0) THEN
1278          MKCRON = 0
1279       ELSE
1280          MKCRON = 1
1281       ENDIF
1282       CRONCO = WHAT(2)
1283       GOTO 10
1284
1285 *********************************************************************
1286 *                                                                   *
1287 *               control card:  codewd = SEADISTR                    *
1288 *                                                                   *
1289 *     what (1)  (XSEACO)  sea(x) prop. 1/x**what (1)   default: 1.  *
1290 *     what (2)  (UNON)                                 default: 2.  *
1291 *     what (3)  (UNOM)                                 default: 1.5 *
1292 *     what (4)  (UNOSEA)                               default: 5.  *
1293 *                        qdis(x) prop. (1-x)**what (1)  etc.        *
1294 *     what (5..6), sdum   no meaning                                *
1295 *                                                                   *
1296 *********************************************************************
1297
1298   340 CONTINUE
1299       XSEACO = WHAT(1)
1300       XSEACU = 1.05D0-XSEACO
1301       UNON   = WHAT(2)
1302       IF (UNON.LT.0.1D0) UNON = 2.0D0
1303       UNOM   = WHAT(3)
1304       IF (UNOM.LT.0.1D0) UNOM = 1.5D0
1305       UNOSEA = WHAT(4)
1306       IF (UNOSEA.LT.0.1D0) UNOSEA = 5.0D0
1307       GOTO 10
1308
1309 *********************************************************************
1310 *                                                                   *
1311 *               control card:  codewd = SEASU3                      *
1312 *                                                                   *
1313 *          Treatment of strange-quarks at chain ends                *
1314 *                                                                   *
1315 *       what (1)   (SEASQ)  strange-quark supression factor         *
1316 *                  iflav = 1.+rndm*(2.+SEASQ)                       *
1317 *                                                    default: 1.    *
1318 *       what (2..6), sdum   no meaning                              *
1319 *                                                                   *
1320 *********************************************************************
1321
1322   350 CONTINUE
1323       SEASQ = WHAT(1)
1324       GOTO 10
1325
1326 *********************************************************************
1327 *                                                                   *
1328 *               control card:  codewd = DIQUARKS                    *
1329 *                                                                   *
1330 *     what (1) = -1.  sea-diquark/antidiquark-pairs not treated     *
1331 *                                                    default: 1.    *
1332 *     what (2..6), sdum   no meaning                                *
1333 *                                                                   *
1334 *********************************************************************
1335
1336  360  CONTINUE
1337       IF (WHAT(1).EQ.-1.0D0) THEN
1338          LSEADI = .FALSE.
1339       ELSE
1340          LSEADI = .TRUE.
1341       ENDIF
1342       GOTO 10
1343
1344 *********************************************************************
1345 *                                                                   *
1346 *               control card:  codewd = RESONANC                    *
1347 *                                                                   *
1348 *                 treatment of low mass chains                      *
1349 *                                                                   *
1350 *    what (1) = -1 low chain masses are not corrected for resonance *
1351 *                  masses (obsolete for BAMJET-fragmentation)       *
1352 *                                       default: 1.                 *
1353 *    what (2) = -1 massless partons     default: 1. (massive)       *
1354 *                                       default: 1. (massive)       *
1355 *    what (3) = -1 chain-system containing chain of too small       *
1356 *                  mass is rejected (note: this does not fully      *
1357 *                  apply to S-S chains) default: 0.                 *
1358 *    what (4..6), sdum   no meaning                                 *
1359 *                                                                   *
1360 *********************************************************************
1361
1362   370 CONTINUE
1363       IRESCO = 1
1364       IMSHL  = 1
1365       IRESRJ = 0
1366       IF (WHAT(1).EQ.-ONE) IRESCO = 0
1367       IF (WHAT(2).EQ.-ONE) IMSHL  = 0
1368       IF (WHAT(3).EQ.-ONE) IRESRJ = 1
1369       GOTO 10
1370
1371 *********************************************************************
1372 *                                                                   *
1373 *               control card:  codewd = DIFFRACT                    *
1374 *                                                                   *
1375 *                Treatment of diffractive events                    *
1376 *                                                                   *
1377 *     what (1) = (ISINGD) 0  no single diffraction                  *
1378 *                         1  single diffraction included            *
1379 *                       +-2  single diffractive events only         *
1380 *                       +-3  projectile single diffraction only     *
1381 *                       +-4  target single diffraction only         *
1382 *                        -5  double pomeron exchange only           *
1383 *                      (neg. sign applies to PHOJET events)         *
1384 *                                                     default: 0.   *
1385 *                                                                   *
1386 *     what (2) = (IDOUBD) 0  no double diffraction                  *
1387 *                         1  double diffraction included            *
1388 *                         2  double diffractive events only         *
1389 *                                                     default: 0.   *
1390 *     what (3) = 1 projectile diffraction treated (2-channel form.) *
1391 *                                                     default: 0.   *
1392 *     what (4) = alpha-parameter in projectile diffraction          *
1393 *                                                     default: 0.   *
1394 *     what (5..6), sdum   no meaning                                *
1395 *                                                                   *
1396 *********************************************************************
1397
1398   380 CONTINUE
1399       IF (ABS(WHAT(1)).GT.ZERO) ISINGD = INT(WHAT(1))
1400       IF (ABS(WHAT(2)).GT.ZERO) IDOUBD = INT(WHAT(2))
1401       IF ((ISINGD.GT.1).AND.(IDOUBD.GT.1)) THEN
1402          WRITE(LOUT,1380)
1403  1380    FORMAT(1X,'INIT:   inconsistent DIFFRACT - input !',/,
1404      &          11X,'IDOUBD is reset to zero')
1405          IDOUBD = 0
1406       ENDIF
1407       IF (WHAT(3).GT.ZERO) DIBETA = WHAT(3)
1408       IF (WHAT(4).GT.ZERO) DIALPH = WHAT(4)
1409       GOTO 10
1410
1411 *********************************************************************
1412 *                                                                   *
1413 *               control card:  codewd = SINGLECH                    *
1414 *                                                                   *
1415 *       what (1) = 1.  Regge contribution (one chain) included      *
1416 *                                                   default: 0.     *
1417 *       what (2..6), sdum   no meaning                              *
1418 *                                                                   *
1419 *********************************************************************
1420
1421  390  CONTINUE
1422       ISICHA = 0
1423       IF (WHAT(1).EQ.ONE) ISICHA = 1
1424       GOTO 10
1425
1426 *********************************************************************
1427 *                                                                   *
1428 *               control card:  codewd = NOFRAGME                    *
1429 *                                                                   *
1430 *                 biased chain hadronization                        *
1431 *                                                                   *
1432 *       what (1..6) = -1  no of hadronizsation of S-S chains        *
1433 *                   = -2  no of hadronizsation of D-S chains        *
1434 *                   = -3  no of hadronizsation of S-D chains        *
1435 *                   = -4  no of hadronizsation of S-V chains        *
1436 *                   = -5  no of hadronizsation of D-V chains        *
1437 *                   = -6  no of hadronizsation of V-S chains        *
1438 *                   = -7  no of hadronizsation of V-D chains        *
1439 *                   = -8  no of hadronizsation of V-V chains        *
1440 *                   = -9  no of hadronizsation of comb. chains      *
1441 *                                  default:  complete hadronization *
1442 *       sdum   no meaning                                           *
1443 *                                                                   *
1444 *********************************************************************
1445
1446   400 CONTINUE
1447       DO 401 I=1,6
1448          ICHAIN = INT(WHAT(I))
1449          IF ((ICHAIN.LE.-1).AND.(ICHAIN.GE.-9))
1450      &      LHADRO(ABS(ICHAIN)) = .FALSE.
1451   401 CONTINUE
1452       GOTO 10
1453
1454 *********************************************************************
1455 *                                                                   *
1456 *               control card:  codewd = HADRONIZE                   *
1457 *                                                                   *
1458 *           hadronization model and parameter switch                *
1459 *                                                                   *
1460 *       what (1) = 1    hadronization via BAMJET                    *
1461 *                = 2    hadronization via JETSET                    *
1462 *                                                    default: 2     *
1463 *       what (2) = 1..3 parameter set to be used                    *
1464 *                       JETSET: 3 sets available                    *
1465 *                               ( = 3 default JETSET-parameters)    *
1466 *                       BAMJET: 1 set available                     *
1467 *                                                    default: 1     *
1468 *       what (3..6), sdum   no meaning                              *
1469 *                                                                   *
1470 *********************************************************************
1471
1472   410 CONTINUE
1473       IWHAT1 = INT(WHAT(1))
1474       IWHAT2 = INT(WHAT(2))
1475       IF ((IWHAT1.EQ.1).OR.(IWHAT1.EQ.2)) IFRAG(1) = IWHAT1
1476       IF ((IWHAT1.EQ.2).AND.(IWHAT2.GE.1).AND.(IWHAT2.LE.3))
1477      &                                    IFRAG(2) = IWHAT2
1478       GOTO 10
1479
1480 *********************************************************************
1481 *                                                                   *
1482 *               control card:  codewd = POPCORN                     *
1483 *                                                                   *
1484 *  "Popcorn-effect" in fragmentation and diquark breaking diagrams  *
1485 *                                                                   *
1486 *   what (1) = (PDB) frac. of diquark fragmenting directly into     *
1487 *                    baryons (PYTHIA/JETSET fragmentation)          *
1488 *                    (JETSET: = 0. Popcorn mechanism switched off)  *
1489 *                                                    default: 0.5   *
1490 *   what (2) = probability for accepting a diquark breaking         *
1491 *              diagram involving the generation of a u/d quark-     *
1492 *              antiquark pair                        default: 0.0   *
1493 *   what (3) = same a what (2), here for s quark-antiquark pair     *
1494 *                                                    default: 0.0   *
1495 *   what (4..6), sdum   no meaning                                  *
1496 *                                                                   *
1497 *********************************************************************
1498
1499   420 CONTINUE
1500       IF (WHAT(1).GE.0.0D0) PDB = WHAT(1)
1501       IF (WHAT(2).GE.0.0D0) THEN
1502          PDBSEA(1) = WHAT(2)
1503          PDBSEA(2) = WHAT(2)
1504       ENDIF
1505       IF (WHAT(3).GE.0.0D0) PDBSEA(3) = WHAT(3)
1506       DO 421 I=1,8
1507          DBRKA(1,I) = DBRKR(1,I)*PDBSEA(1)/(1.D0-PDBSEA(1))
1508          DBRKA(2,I) = DBRKR(2,I)*PDBSEA(2)/(1.D0-PDBSEA(2))
1509          DBRKA(3,I) = DBRKR(3,I)*PDBSEA(3)/(1.D0-PDBSEA(3))
1510   421 CONTINUE
1511       GOTO 10
1512
1513 *********************************************************************
1514 *                                                                   *
1515 *               control card:  codewd = PARDECAY                    *
1516 *                                                                   *
1517 *      what (1) = 1.  Sigma0/Asigma0 are decaying within JETSET     *
1518 *               = 2.  pion^0 decay after intranucl. cascade         *
1519 *                                                default: no decay  *
1520 *      what (2..6), sdum   no meaning                               *
1521 *                                                                   *
1522 *********************************************************************
1523
1524  430  CONTINUE
1525       IF (WHAT(1).EQ.ONE)  ISIG0 = 1
1526       IF (WHAT(1).EQ.2.0D0) IPI0 = 1
1527       GOTO 10
1528
1529 *********************************************************************
1530 *                                                                   *
1531 *               control card:  codewd = BEAM                        *
1532 *                                                                   *
1533 *              definition of beam parameters                        *
1534 *                                                                   *
1535 *      what (1/2)  > 0 : energy of beam 1/2 (GeV)                   *
1536 *                  < 0 : abs(what(1/2)) energy per charge of        *
1537 *                        beam 1/2 (GeV)                             *
1538 *                  (beam 1 is directed into positive z-direction)   *
1539 *      what (3)    beam crossing angle, defined as 2x angle between *
1540 *                  one beam and the z-axis (micro rad)              *
1541 *      what (4)    angle with x-axis defining the collision plane   *
1542 *      what (5..6), sdum   no meaning                               *
1543 *                                                                   *
1544 *      Note: this card requires previously defined projectile and   *
1545 *            target identities (PROJPAR, TARPAR)                    *
1546 *                                                                   *
1547 *********************************************************************
1548
1549   440 CONTINUE
1550       CALL DT_BEAMPR(WHAT,PPN,1)
1551       EPN    = ZERO
1552       CMENER = ZERO
1553       LEINP  = .TRUE.
1554       GOTO 10
1555
1556 *********************************************************************
1557 *                                                                   *
1558 *               control card:  codewd = LUND-MSTU                   *
1559 *                                                                   *
1560 *          set parameter MSTU in JETSET-common /LUDAT1/             *
1561 *                                                                   *
1562 *       what (1) =  index according to LUND-common block            *
1563 *       what (2) =  new value of MSTU( int(what(1)) )               *
1564 *       what (3), what(4) and what (5), what(6) further             *
1565 *                   parameter in the same way as what (1) and       *
1566 *                   what (2)                                        *
1567 *                        default: default-Lund or corresponding to  *
1568 *                                 the set given in HADRONIZE        *
1569 *                                                                   *
1570 *********************************************************************
1571
1572   450 CONTINUE
1573       IF (WHAT(1).GT.ZERO) THEN
1574          NMSTU = NMSTU+1
1575          IMSTU(NMSTU) = INT(WHAT(1))
1576          MSTUX(NMSTU) = INT(WHAT(2))
1577       ENDIF
1578       IF (WHAT(3).GT.ZERO) THEN
1579          NMSTU = NMSTU+1
1580          IMSTU(NMSTU) = INT(WHAT(3))
1581          MSTUX(NMSTU) = INT(WHAT(4))
1582       ENDIF
1583       IF (WHAT(5).GT.ZERO) THEN
1584          NMSTU = NMSTU+1
1585          IMSTU(NMSTU) = INT(WHAT(5))
1586          MSTUX(NMSTU) = INT(WHAT(6))
1587       ENDIF
1588       GOTO 10
1589
1590 *********************************************************************
1591 *                                                                   *
1592 *               control card:  codewd = LUND-MSTJ                   *
1593 *                                                                   *
1594 *          set parameter MSTJ in JETSET-common /LUDAT1/             *
1595 *                                                                   *
1596 *       what (1) =  index according to LUND-common block            *
1597 *       what (2) =  new value of MSTJ( int(what(1)) )               *
1598 *       what (3), what(4) and what (5), what(6) further             *
1599 *                   parameter in the same way as what (1) and       *
1600 *                   what (2)                                        *
1601 *                        default: default-Lund or corresponding to  *
1602 *                                 the set given in HADRONIZE        *
1603 *                                                                   *
1604 *********************************************************************
1605
1606   451 CONTINUE
1607       IF (WHAT(1).GT.ZERO) THEN
1608          NMSTJ = NMSTJ+1
1609          IMSTJ(NMSTJ) = INT(WHAT(1))
1610          MSTJX(NMSTJ) = INT(WHAT(2))
1611       ENDIF
1612       IF (WHAT(3).GT.ZERO) THEN
1613          NMSTJ = NMSTJ+1
1614          IMSTJ(NMSTJ) = INT(WHAT(3))
1615          MSTJX(NMSTJ) = INT(WHAT(4))
1616       ENDIF
1617       IF (WHAT(5).GT.ZERO) THEN
1618          NMSTJ = NMSTJ+1
1619          IMSTJ(NMSTJ) = INT(WHAT(5))
1620          MSTJX(NMSTJ) = INT(WHAT(6))
1621       ENDIF
1622       GOTO 10
1623
1624 *********************************************************************
1625 *                                                                   *
1626 *               control card:  codewd = LUND-MDCY                   *
1627 *                                                                   *
1628 *  set parameter MDCY(I,1) for particle decays in JETSET-common     *
1629 *                                                      /LUDAT3/     *
1630 *                                                                   *
1631 *       what (1-6) = PDG particle index of particle which should    *
1632 *                    not decay                                      *
1633 *                        default: default-Lund or forced in         *
1634 *                                 DT_INITJS                         *
1635 *                                                                   *
1636 *********************************************************************
1637
1638   452 CONTINUE
1639       DO 4521 I=1,6
1640          IF (WHAT(I).NE.ZERO) THEN
1641
1642             KC = PYCOMP(INT(WHAT(I)))
1643
1644             MDCY(KC,1) = 0
1645          ENDIF
1646  4521 CONTINUE
1647       GOTO 10
1648
1649 *********************************************************************
1650 *                                                                   *
1651 *               control card:  codewd = LUND-PARJ                   *
1652 *                                                                   *
1653 *          set parameter PARJ in JETSET-common /LUDAT1/             *
1654 *                                                                   *
1655 *       what (1) =  index according to LUND-common block            *
1656 *       what (2) =  new value of PARJ( int(what(1)) )               *
1657 *       what (3), what(4) and what (5), what(6) further             *
1658 *                   parameter in the same way as what (1) and       *
1659 *                   what (2)                                        *
1660 *                        default: default-Lund or corresponding to  *
1661 *                                 the set given in HADRONIZE        *
1662 *                                                                   *
1663 *********************************************************************
1664
1665   460 CONTINUE
1666       IF (WHAT(1).NE.ZERO) THEN
1667          NPARJ = NPARJ+1
1668          IPARJ(NPARJ) = INT(WHAT(1))
1669          PARJX(NPARJ) = WHAT(2)
1670       ENDIF
1671       IF (WHAT(3).NE.ZERO) THEN
1672          NPARJ = NPARJ+1
1673          IPARJ(NPARJ) = INT(WHAT(3))
1674          PARJX(NPARJ) = WHAT(4)
1675       ENDIF
1676       IF (WHAT(5).NE.ZERO) THEN
1677          NPARJ = NPARJ+1
1678          IPARJ(NPARJ) = INT(WHAT(5))
1679          PARJX(NPARJ) = WHAT(6)
1680       ENDIF
1681       GOTO 10
1682
1683 *********************************************************************
1684 *                                                                   *
1685 *               control card:  codewd = LUND-PARU                   *
1686 *                                                                   *
1687 *          set parameter PARJ in JETSET-common /LUDAT1/             *
1688 *                                                                   *
1689 *       what (1) =  index according to LUND-common block            *
1690 *       what (2) =  new value of PARU( int(what(1)) )               *
1691 *       what (3), what(4) and what (5), what(6) further             *
1692 *                   parameter in the same way as what (1) and       *
1693 *                   what (2)                                        *
1694 *                        default: default-Lund or corresponding to  *
1695 *                                 the set given in HADRONIZE        *
1696 *                                                                   *
1697 *********************************************************************
1698
1699   470 CONTINUE
1700       IF (WHAT(1).GT.ZERO) THEN
1701          NPARU = NPARU+1
1702          IPARU(NPARU) = INT(WHAT(1))
1703          PARUX(NPARU) = WHAT(2)
1704       ENDIF
1705       IF (WHAT(3).GT.ZERO) THEN
1706          NPARU = NPARU+1
1707          IPARU(NPARU) = INT(WHAT(3))
1708          PARUX(NPARU) = WHAT(4)
1709       ENDIF
1710       IF (WHAT(5).GT.ZERO) THEN
1711          NPARU = NPARU+1
1712          IPARU(NPARU) = INT(WHAT(5))
1713          PARUX(NPARU) = WHAT(6)
1714       ENDIF
1715       GOTO 10
1716
1717 *********************************************************************
1718 *                                                                   *
1719 *               control card:  codewd = OUTLEVEL                    *
1720 *                                                                   *
1721 *                    output control switches                        *
1722 *                                                                   *
1723 *       what (1) =  internal rejection informations  default: 0     *
1724 *       what (2) =  energy-momentum conservation check output       *
1725 *                                                    default: 0     *
1726 *       what (3) =  internal warning messages        default: 0     *
1727 *       what (4..6), sdum    not yet used                           *
1728 *                                                                   *
1729 *********************************************************************
1730
1731   480 CONTINUE
1732       DO 481 K=1,6
1733          IOULEV(K) = INT(WHAT(K))
1734   481 CONTINUE
1735       GOTO 10
1736
1737 *********************************************************************
1738 *                                                                   *
1739 *               control card:  codewd = FRAME                       *
1740 *                                                                   *
1741 *          frame in which final state is given in DTEVT1            *
1742 *                                                                   *
1743 *       what (1) = 1  target rest frame (laboratory)                *
1744 *                = 2  nucleon-nucleon cms                           *
1745 *                                                    default: 1     *
1746 *                                                                   *
1747 *********************************************************************
1748
1749   490 CONTINUE
1750       KFRAME = INT(WHAT(1))
1751       IF ((KFRAME.GE.1).AND.(KFRAME.LE.2)) IFRAME = KFRAME
1752       GOTO 10
1753
1754 *********************************************************************
1755 *                                                                   *
1756 *               control card:  codewd = L-TAG                       *
1757 *                                                                   *
1758 *                        lepton tagger:                             *
1759 *   definition of kinematical cuts for radiated photon and          *
1760 *   outgoing lepton detection in lepton-nucleus interactions        *
1761 *                                                                   *
1762 *       what (1) = y_min                                            *
1763 *       what (2) = y_max                                            *
1764 *       what (3) = Q^2_min                                          *
1765 *       what (4) = Q^2_max                                          *
1766 *       what (5) = theta_min  (Lab)                                 *
1767 *       what (6) = theta_max  (Lab)                                 *
1768 *                                       default: no cuts            *
1769 *       sdum    no meaning                                          *
1770 *                                                                   *
1771 *********************************************************************
1772
1773   500 CONTINUE
1774       YMIN  = WHAT(1)
1775       YMAX  = WHAT(2)
1776       Q2MIN = WHAT(3)
1777       Q2MAX = WHAT(4)
1778       THMIN = WHAT(5)
1779       THMAX = WHAT(6)
1780       GOTO 10
1781
1782 *********************************************************************
1783 *                                                                   *
1784 *               control card:  codewd = L-ETAG                      *
1785 *                                                                   *
1786 *                        lepton tagger:                             *
1787 *       what (1) = min. outgoing lepton energy  (in Lab)            *
1788 *       what (2) = min. photon energy           (in Lab)            *
1789 *       what (3) = max. photon energy           (in Lab)            *
1790 *                                       default: no cuts            *
1791 *       what (2..6), sdum    no meaning                             *
1792 *                                                                   *
1793 *********************************************************************
1794
1795   510 CONTINUE
1796       ELMIN = MAX(WHAT(1),ZERO)
1797       EGMIN = MAX(WHAT(2),ZERO)
1798       EGMAX = MAX(WHAT(3),ZERO)
1799       GOTO 10
1800
1801 *********************************************************************
1802 *                                                                   *
1803 *               control card:  codewd = ECMS-CUT                    *
1804 *                                                                   *
1805 *     what (1) = min. c.m. energy to be sampled                     *
1806 *     what (2) = max. c.m. energy to be sampled                     *
1807 *     what (3) = min x_Bj         to be sampled                     *
1808 *                                       default: no cuts            *
1809 *     what (3..6), sdum    no meaning                               *
1810 *                                                                   *
1811 *********************************************************************
1812
1813   520 CONTINUE
1814       ECMIN  = WHAT(1)
1815       ECMAX  = WHAT(2)
1816       IF (ECMIN.GT.ECMAX) ECMIN = ECMAX
1817       XBJMIN = MAX(WHAT(3),ZERO)
1818       GOTO 10
1819
1820 *********************************************************************
1821 *                                                                   *
1822 *               control card:  codewd = VDM-PAR1                    *
1823 *                                                                   *
1824 *      parameters in gamma-nucleus cross section calculation        *
1825 *                                                                   *
1826 *       what (1) =  Lambda^2                       default: 2.      *
1827 *       what (2)    lower limit in M^2 integration                  *
1828 *                =  1  (3m_pi)^2                                    *
1829 *                =  2  (m_rho0)^2                                   *
1830 *                =  3  (m_phi)^2                   default: 1       *
1831 *       what (3)    upper limit in M^2 integration                  *
1832 *                =  1   s/2                                         *
1833 *                =  2   s/4                                         *
1834 *                =  3   s                          default: 3       *
1835 *       what (4)    CKMT F_2 structure function                     *
1836 *                =  2212  proton                                    *
1837 *                =  100   deuteron                 default: 2212    *
1838 *       what (5)    calculation of gamma-nucleon xsections          *
1839 *                =  1  according to CKMT-parametrization of F_2     *
1840 *                =  2  integrating SIGVP over M^2                   *
1841 *                =  3  using SIGGA                                  *
1842 *                =  4  PHOJET cross sections       default:  4      *
1843 *                                                                   *
1844 *       what (6), sdum    no meaning                                *
1845 *                                                                   *
1846 *********************************************************************
1847
1848   530 CONTINUE
1849       IF (WHAT(1).GE.ZERO) RL2 = WHAT(1)
1850       IF ((WHAT(2).GE.1).AND.(WHAT(2).LE.3)) INTRGE(1) = INT(WHAT(2))
1851       IF ((WHAT(3).GE.1).AND.(WHAT(3).LE.3)) INTRGE(2) = INT(WHAT(3))
1852       IF ((WHAT(4).EQ.2212).OR.(WHAT(4).EQ.100)) IDPDF = INT(WHAT(4))
1853       IF ((WHAT(5).GE.1).AND.(WHAT(5).LE.4)) MODEGA = INT(WHAT(5))
1854       GOTO 10
1855
1856 *********************************************************************
1857 *                                                                   *
1858 *               control card:  codewd = HISTOGRAM                   *
1859 *                                                                   *
1860 *           activate different classes of histograms                *
1861 *                                                                   *
1862 *                                default: no histograms             *
1863 *                                                                   *
1864 *********************************************************************
1865
1866   540 CONTINUE
1867       DO 541 J=1,6
1868          IF ((WHAT(J).GE.100).AND.(WHAT(J).LE.150)) THEN
1869             IHISPP(INT(WHAT(J))-100) = 1
1870          ELSEIF ((ABS(WHAT(J)).GE.200).AND.(ABS(WHAT(J)).LE.250)) THEN
1871             IHISXS(INT(ABS(WHAT(J)))-200) = 1
1872             IF (WHAT(J).LT.ZERO) IXSTBL = 1
1873          ENDIF
1874   541 CONTINUE
1875       GOTO 10
1876
1877 *********************************************************************
1878 *                                                                   *
1879 *               control card:  codewd = XS-TABLE                    *
1880 *                                                                   *
1881 *    output of cross section table for requested interaction        *
1882 *              - particle production deactivated ! -                *
1883 *                                                                   *
1884 *       what (1)      lower energy limit for tabulation             *
1885 *                > 0  Lab. frame                                    *
1886 *                < 0  nucleon-nucleon cms                           *
1887 *       what (2)      upper energy limit for tabulation             *
1888 *                > 0  Lab. frame                                    *
1889 *                < 0  nucleon-nucleon cms                           *
1890 *       what (3) > 0  # of equidistant lin. bins in E               *
1891 *                < 0  # of equidistant log. bins in E               *
1892 *       what (4)      lower limit of particle virtuality (photons)  *
1893 *       what (5)      upper limit of particle virtuality (photons)  *
1894 *       what (6) > 0  # of equidistant lin. bins in Q^2             *
1895 *                < 0  # of equidistant log. bins in Q^2             *
1896 *                                                                   *
1897 *********************************************************************
1898
1899   550 CONTINUE
1900       IF (WHAT(1).EQ.99999.0D0) THEN
1901          IRATIO = INT(WHAT(2))
1902          GOTO 10
1903       ENDIF
1904       CMENER = ABS(WHAT(2))
1905       IF (.NOT.LXSTAB) THEN
1906
1907          CALL NCDTRD
1908          CALL INCINI
1909
1910       ENDIF
1911       IF ((.NOT.LXSTAB).OR.(CMENER.NE.CMEOLD)) THEN
1912          CMEOLD = CMENER
1913          IF (WHAT(2).GT.ZERO)
1914      &      CMENER = SQRT(2.0D0*AAM(1)**2+2.0D0*WHAT(2)*AAM(1))
1915          EPN = ZERO
1916          PPN = ZERO
1917 C        WRITE(LOUT,*) 'CMENER = ',CMENER
1918          CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,CMENER,1)
1919          CALL DT_PHOINI
1920       ENDIF
1921       CALL DT_XSTABL(WHAT,IXSQEL,IRATIO)
1922       IXSQEL = 0
1923       LXSTAB = .TRUE.
1924       GOTO 10
1925
1926 *********************************************************************
1927 *                                                                   *
1928 *               control card:  codewd = GLAUB-PAR                   *
1929 *                                                                   *
1930 *                parameters in Glauber-formalism                    *
1931 *                                                                   *
1932 *    what (1)  # of nucleon configurations sampled in integration   *
1933 *              over nuclear desity                default: 1000     *
1934 *    what (2)  # of bins for integration over impact-parameter and  *
1935 *              for profile-function calculation   default: 49       *
1936 *    what (3)  = 1 calculation of tot., el. and qel. cross sections *
1937 *                                                 default: 0        *
1938 *    what (4)  = 1   read pre-calculated impact-parameter distrib.  *
1939 *                    from "sdum".glb                                *
1940 *              =-1   dump pre-calculated impact-parameter distrib.  *
1941 *                    into "sdum".glb                                *
1942 *              = 100 read pre-calculated impact-parameter distrib.  *
1943 *                    for variable projectile/target/energy runs     *
1944 *                    from "sdum".glb                                *
1945 *                                                 default: 0        *
1946 *    what (5..6)   no meaning                                       *
1947 *    sdum      if |what (4)| = 1 name of in/output-file (sdum.glb)  *
1948 *                                                                   *
1949 *********************************************************************
1950
1951   560 CONTINUE
1952       IF (WHAT(1).GT.ZERO) JSTATB = INT(WHAT(1))
1953       IF (WHAT(2).GT.ZERO) JBINSB = INT(WHAT(2))
1954       IF (WHAT(3).EQ.ONE) LPROD = .FALSE.
1955       IF ((ABS(WHAT(4)).EQ.ONE).OR.(WHAT(4).EQ.100)) THEN
1956          IOGLB = INT(WHAT(4))
1957          CGLB  = SDUM
1958       ENDIF
1959       GOTO 10
1960
1961 *********************************************************************
1962 *                                                                   *
1963 *               control card:  codewd = GLAUB-INI                   *
1964 *                                                                   *
1965 *             pre-initialization of profile function                *
1966 *                                                                   *
1967 *       what (1)      lower energy limit for initialization         *
1968 *                > 0  Lab. frame                                    *
1969 *                < 0  nucleon-nucleon cms                           *
1970 *       what (2)      upper energy limit for initialization         *
1971 *                > 0  Lab. frame                                    *
1972 *                < 0  nucleon-nucleon cms                           *
1973 *       what (3) > 0  # of equidistant lin. bins in E               *
1974 *                < 0  # of equidistant log. bins in E               *
1975 *       what (4)      maximum projectile mass number for which the  *
1976 *                     Glauber data are initialized for each         *
1977 *                     projectile mass number                        *
1978 *                     (if <= mass given with the PROJPAR-card)      *
1979 *                                              default: 18          *
1980 *       what (5)      steps in mass number starting from what (4)   *
1981 *                     up to mass number defined with PROJPAR-card   *
1982 *                     for which Glauber data are initialized        *
1983 *                                              default: 5           *
1984 *       what (6)      no meaning                                    *
1985 *       sdum          no meaning                                    *
1986 *                                                                   *
1987 *********************************************************************
1988
1989   565 CONTINUE
1990       IOGLB = -100
1991       CALL DT_GLBINI(WHAT)
1992       GOTO 10
1993
1994 *********************************************************************
1995 *                                                                   *
1996 *               control card:  codewd = VDM-PAR2                    *
1997 *                                                                   *
1998 *      parameters in gamma-nucleus cross section calculation        *
1999 *                                                                   *
2000 *      what (1) = 0 no suppression of shadowing by direct photon    *
2001 *                   processes                                       *
2002 *               = 1 suppression ..                   default: 1     *
2003 *      what (2) = 0 no suppression of shadowing by anomalous        *
2004 *                   component if photon-F_2                         *
2005 *               = 1 suppression ..                   default: 1     *
2006 *      what (3) = 0 no suppression of shadowing by coherence        *
2007 *                   length of the photon                            *
2008 *               = 1 suppression ..                   default: 1     *
2009 *      what (4) = 1 longitudinal polarized photons are taken into   *
2010 *                   account                                         *
2011 *                   eps*R*Q^2/M^2 = what(4)*Q^2/M^2  default: 0     *
2012 *      what (5..6), sdum    no meaning                              *
2013 *                                                                   *
2014 *********************************************************************
2015
2016   570 CONTINUE
2017       IF ((WHAT(1).EQ.ZERO).OR.(WHAT(1).EQ.ONE)) ISHAD(1) = INT(WHAT(1))
2018       IF ((WHAT(2).EQ.ZERO).OR.(WHAT(2).EQ.ONE)) ISHAD(2) = INT(WHAT(2))
2019       IF ((WHAT(3).EQ.ZERO).OR.(WHAT(3).EQ.ONE)) ISHAD(3) = INT(WHAT(3))
2020       EPSPOL  = WHAT(4)
2021       GOTO 10
2022
2023 *********************************************************************
2024 *                                                                   *
2025 *               control card:  XS-QELPRO                            *
2026 *                                                                   *
2027 *     what (1..6), sdum    no meaning                               *
2028 *                                                                   *
2029 *********************************************************************
2030
2031   580 CONTINUE
2032       IXSQEL = ABS(WHAT(1))
2033       GOTO 10
2034
2035 *********************************************************************
2036 *                                                                   *
2037 *               control card:  RNDMINIT                             *
2038 *                                                                   *
2039 *           initialization of random number generator               *
2040 *                                                                   *
2041 *     what (1..4)    values for initialization (= 1..168)           *
2042 *     what (5..6), sdum    no meaning                               *
2043 *                                                                   *
2044 *********************************************************************
2045
2046   590 CONTINUE
2047       IF ((WHAT(1).LT.1.0D0).OR.(WHAT(1).GT.168.0D0)) THEN
2048          NA1 = 22
2049       ELSE
2050          NA1 = WHAT(1)
2051       ENDIF
2052       IF ((WHAT(2).LT.1.0D0).OR.(WHAT(2).GT.168.0D0)) THEN
2053          NA2 = 54
2054       ELSE
2055          NA2 = WHAT(2)
2056       ENDIF
2057       IF ((WHAT(3).LT.1.0D0).OR.(WHAT(3).GT.168.0D0)) THEN
2058          NA3 = 76
2059       ELSE
2060          NA3 = WHAT(3)
2061       ENDIF
2062       IF ((WHAT(4).LT.1.0D0).OR.(WHAT(4).GT.168.0D0)) THEN
2063          NA4 = 92
2064       ELSE
2065          NA4 = WHAT(4)
2066       ENDIF
2067       CALL DT_RNDMST(NA1,NA2,NA3,NA4)
2068       GOTO 10
2069
2070 *********************************************************************
2071 *                                                                   *
2072 *               control card:  codewd = LEPTO-CUT                   *
2073 *                                                                   *
2074 *          set parameter CUT in LEPTO-common /LEPTOU/               *
2075 *                                                                   *
2076 *       what (1) =  index in CUT-array                              *
2077 *       what (2) =  new value of CUT( int(what(1)) )                *
2078 *       what (3), what(4) and what (5), what(6) further             *
2079 *                   parameter in the same way as what (1) and       *
2080 *                   what (2)                                        *
2081 *                        default: default-LEPTO parameters          *
2082 *                                                                   *
2083 *********************************************************************
2084
2085   600 CONTINUE
2086       IF (WHAT(1).GT.ZERO) CUT(INT(WHAT(1))) = WHAT(2)
2087       IF (WHAT(3).GT.ZERO) CUT(INT(WHAT(3))) = WHAT(4)
2088       IF (WHAT(5).GT.ZERO) CUT(INT(WHAT(5))) = WHAT(6)
2089       GOTO 10
2090
2091 *********************************************************************
2092 *                                                                   *
2093 *               control card:  codewd = LEPTO-LST                   *
2094 *                                                                   *
2095 *          set parameter LST in LEPTO-common /LEPTOU/               *
2096 *                                                                   *
2097 *       what (1) =  index in LST-array                              *
2098 *       what (2) =  new value of LST( int(what(1)) )                *
2099 *       what (3), what(4) and what (5), what(6) further             *
2100 *                   parameter in the same way as what (1) and       *
2101 *                   what (2)                                        *
2102 *                        default: default-LEPTO parameters          *
2103 *                                                                   *
2104 *********************************************************************
2105
2106   610 CONTINUE
2107       IF (WHAT(1).GT.ZERO) LST(INT(WHAT(1))) = INT(WHAT(2))
2108       IF (WHAT(3).GT.ZERO) LST(INT(WHAT(3))) = INT(WHAT(4))
2109       IF (WHAT(5).GT.ZERO) LST(INT(WHAT(5))) = INT(WHAT(6))
2110       GOTO 10
2111
2112 *********************************************************************
2113 *                                                                   *
2114 *               control card:  codewd = LEPTO-PARL                  *
2115 *                                                                   *
2116 *          set parameter PARL in LEPTO-common /LEPTOU/              *
2117 *                                                                   *
2118 *       what (1) =  index in PARL-array                             *
2119 *       what (2) =  new value of PARL( int(what(1)) )               *
2120 *       what (3), what(4) and what (5), what(6) further             *
2121 *                   parameter in the same way as what (1) and       *
2122 *                   what (2)                                        *
2123 *                        default: default-LEPTO parameters          *
2124 *                                                                   *
2125 *********************************************************************
2126
2127   620 CONTINUE
2128       IF (WHAT(1).GT.ZERO) PARL(INT(WHAT(1))) = WHAT(2)
2129       IF (WHAT(3).GT.ZERO) PARL(INT(WHAT(3))) = WHAT(4)
2130       IF (WHAT(5).GT.ZERO) PARL(INT(WHAT(5))) = WHAT(6)
2131       GOTO 10
2132
2133 *********************************************************************
2134 *                                                                   *
2135 *               control card:  codewd = START                       *
2136 *                                                                   *
2137 *       what (1) =   number of events                default: 100.  *
2138 *       what (2) = 0 Glauber initialization follows                 *
2139 *                = 1 Glauber initialization supressed, fitted       *
2140 *                    results are used instead                       *
2141 *                    (this does not apply if emulsion-treatment     *
2142 *                     is requested)                                 *
2143 *                = 2 Glauber initialization is written to           *
2144 *                    output-file shmakov.out                        *
2145 *                = 3 Glauber initialization is read from input-file *
2146 *                    shmakov.out                     default: 0     *
2147 *       what (3..6)  no meaning                                     *
2148 *       what (3..6)  no meaning                                     *
2149 *                                                                   *
2150 *********************************************************************
2151
2152   630 CONTINUE
2153
2154 * check for cross-section table output only
2155       IF (LXSTAB) STOP
2156
2157       NCASES = INT(WHAT(1))
2158       IF (NCASES.LE.0) NCASES = 100
2159       IGLAU = INT(WHAT(2))
2160       IF ((IGLAU.NE.1).AND.(IGLAU.NE.2).AND.(IGLAU.NE.3))
2161      &                                            IGLAU = 0
2162
2163       NPMASS = IP
2164       NPCHAR = IPZ
2165       NTMASS = IT
2166       NTCHAR = ITZ
2167       IDP    = IJPROJ
2168       IDT    = IJTARG
2169       IF (IDP.LE.0) IDP = 1
2170 * muon neutrinos: temporary (missing index)
2171 * (new patch in projpar: therefore the following this is probably not
2172 *  necessary anymore..)
2173 C     IF (IDP.EQ.26) IDP = 5
2174 C     IF (IDP.EQ.27) IDP = 6
2175
2176 * redefine collision energy
2177       IF (LEINP) THEN
2178          IF (ABS(VAREHI).GT.ZERO) THEN
2179             PDUM = ZERO
2180             IF (VARELO.LT.EHADLO) VARELO = EHADLO
2181             CALL DT_LTINI(IDP,IDT,VARELO,PDUM,VARCLO,1)
2182             PDUM = ZERO
2183             CALL DT_LTINI(IDP,IDT,VAREHI,PDUM,VARCHI,1)
2184          ENDIF
2185          CALL DT_LTINI(IDP,IDT,EPN,PPN,CMENER,1)
2186       ELSE
2187          WRITE(LOUT,1003)
2188  1003    FORMAT(1X,'INIT:   collision energy not defined!',/,
2189      &          1X,'              -program stopped-      ')
2190          STOP
2191       ENDIF
2192
2193 * switch off evaporation (even if requested) if central coll. requ.
2194       IF ((ICENTR.EQ.-1).OR.(ICENTR.GT.0).OR.(XSFRAC.LT.0.5D0)) THEN
2195          IF (LEVPRT) THEN
2196             WRITE(LOUT,1004)
2197  1004       FORMAT(1X,/,'Warning!  Evaporation request rejected since',
2198      &             ' central collisions forced.')
2199             LEVPRT = .FALSE.
2200             LDEEXG = .FALSE.
2201             LHEAVY = .FALSE.
2202          ENDIF
2203       ENDIF
2204
2205 * initialization of evaporation-module
2206
2207 *  initialize evaporation if the code is not used as Fluka event generator
2208       WRITE(LOUT,*) '  ITRSPT = ', ITRSPT
2209       IF (ITRSPT.NE.1) THEN
2210          CALL NCDTRD
2211          CALL INCINI
2212       ENDIF
2213       WRITE(LOUT,*) '  LEVPRT = ',LEVPRT
2214       IF (LEVPRT) LHEAVY = .TRUE.
2215 * save the default JETSET-parameter
2216       CALL DT_JSPARA(0)
2217
2218       WRITE(LOUT,*) ' IDP = ',IDP,'  MCGENE = ',MCGENE
2219 * force use of phojet for g-A
2220       IF ((IDP.EQ.7).AND.(MCGENE.NE.3)) MCGENE = 2
2221 * initialization of nucleon-nucleon event generator
2222       IF (MCGENE.EQ.2) CALL DT_PHOINI
2223 * initialization of LEPTO event generator
2224       IF (MCGENE.EQ.3) THEN
2225
2226          STOP ' This version does not contain LEPTO !'
2227
2228       ENDIF
2229
2230 * initialization of quasi-elastic neutrino scattering
2231       IF (MCGENE.EQ.4) THEN
2232          IF (IJPROJ.EQ.5) THEN
2233             NEUTYP = 1
2234          ELSEIF (IJPROJ.EQ.6) THEN
2235             NEUTYP = 2
2236          ELSEIF (IJPROJ.EQ.135) THEN
2237             NEUTYP = 3
2238          ELSEIF (IJPROJ.EQ.136) THEN
2239             NEUTYP = 4
2240          ELSEIF (IJPROJ.EQ.133) THEN
2241             NEUTYP = 5
2242          ELSEIF (IJPROJ.EQ.134) THEN
2243             NEUTYP = 6
2244          ENDIF
2245       ENDIF
2246
2247 * normalize fractions of emulsion components
2248       IF (NCOMPO.GT.0) THEN
2249          SUMFRA = ZERO
2250          DO 491 I=1,NCOMPO
2251             SUMFRA = SUMFRA+EMUFRA(I)
2252   491    CONTINUE
2253          IF (SUMFRA.GT.ZERO) THEN
2254             DO 492 I=1,NCOMPO
2255                EMUFRA(I) = EMUFRA(I)/SUMFRA
2256   492       CONTINUE
2257          ENDIF
2258       ENDIF
2259
2260 * disallow Cronin's multiple scattering for nucleus-nucleus interactions
2261       IF ((IP.GT.1).AND.(MKCRON.GT.0)) THEN
2262          WRITE(LOUT,1005)
2263  1005    FORMAT(/,1X,'INIT:  multiple scattering disallowed',/)
2264          MKCRON = 0
2265       ENDIF
2266
2267 * initialization of Glauber-formalism (moved to xAEVT, sr 26.3.96)
2268 C     IF (NCOMPO.LE.0) THEN
2269 C        CALL DT_SHMAKI(IP,IPZ,IT,ITZ,IDP,PPN,IGLAU)
2270 C     ELSE
2271 C        DO 493 I=1,NCOMPO
2272 C           CALL DT_SHMAKI(IP,IPZ,IEMUMA(I),IEMUCH(I),IDP,PPN,0)
2273 C 493    CONTINUE
2274 C     ENDIF
2275
2276 * pre-tabulation of elastic cross-sections
2277       CALL DT_SIGTBL(JDUM,JDUM,DUM,DUM,-1)
2278
2279       CALL DT_XTIME
2280
2281       RETURN
2282
2283 *********************************************************************
2284 *                                                                   *
2285 *               control card:  codewd = STOP                        *
2286 *                                                                   *
2287 *               stop of the event generation                        *
2288 *                                                                   *
2289 *       what (1..6)  no meaning                                     *
2290 *                                                                   *
2291 *********************************************************************
2292
2293  9999 CONTINUE
2294       WRITE(LOUT,9000)
2295  9000 FORMAT(1X,'---> unexpected end of input !')
2296
2297   640 CONTINUE
2298       STOP
2299
2300       END
2301
2302 *$ CREATE DT_KKINC.FOR
2303 *COPY DT_KKINC
2304 *
2305 *===kkinc==============================================================*
2306 *
2307       SUBROUTINE DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,
2308      &                                                         IREJ)
2309
2310 ************************************************************************
2311 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering   *
2312 * This subroutine is an update of the previous version written         *
2313 * by J. Ranft/ H.-J. Moehring.                                         *
2314 * This version dated 19.11.95 is written by S. Roesler                 *
2315 ************************************************************************
2316
2317       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2318       SAVE
2319
2320       PARAMETER ( LINP = 10 ,
2321      &            LOUT = 6 ,
2322      &            LDAT = 9 )
2323
2324       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY5=1.0D-5,
2325      &           TINY2=1.0D-2,TINY3=1.0D-3)
2326
2327       LOGICAL LFZC
2328
2329 * event history
2330
2331       PARAMETER (NMXHKK=200000)
2332
2333       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2334      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2335      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2336
2337 * extended event history
2338       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2339      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2340      &                IHIST(2,NMXHKK)
2341
2342 * particle properties (BAMJET index convention)
2343       CHARACTER*8  ANAME
2344       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2345      &                IICH(210),IIBAR(210),K1(210),K2(210)
2346
2347 * properties of interacting particles
2348       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2349
2350 * Lorentz-parameters of the current interaction
2351       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
2352      &                UMO,PPCM,EPROJ,PPROJ
2353
2354 * flags for input different options
2355       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2356       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2357      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2358
2359 * flags for particle decays
2360       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2361      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2362      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2363
2364 * cuts for variable energy runs
2365       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2366
2367 * Glauber formalism: flags and parameters for statistics
2368       LOGICAL LPROD
2369       CHARACTER*8 CGLB
2370       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2371
2372       DIMENSION WHAT(6)
2373
2374       IREJ  = 0
2375       ILOOP = 0
2376   100 CONTINUE
2377       IF (ILOOP.EQ.4) THEN
2378          WRITE(LOUT,1000) NEVHKK
2379  1000    FORMAT(1X,'KKINC: event ',I8,' rejected!')
2380          GOTO 9999
2381       ENDIF
2382       ILOOP = ILOOP+1
2383
2384 * variable energy-runs, recalculate parameters for LT's
2385       IF ((ABS(VAREHI).GT.ZERO).OR.(IOGLB.EQ.100)) THEN
2386          PDUM = ZERO
2387          CDUM = ZERO
2388          CALL DT_LTINI(IDP,1,EPN,PDUM,CDUM,1)
2389       ENDIF
2390       IF (EPN.GT.EPROJ) THEN
2391          WRITE(LOUT,'(A,E9.3,2A,E9.3,A)')
2392      &      ' Requested energy (',EPN,'GeV) exceeds',
2393      &      ' initialization energy (',EPROJ,'GeV) !'
2394          STOP
2395       ENDIF
2396
2397 * re-initialize /DTPRTA/
2398       IP  = NPMASS
2399       IPZ = NPCHAR
2400       IT  = NTMASS
2401       ITZ = NTCHAR
2402       IJPROJ = IDP
2403       IBPROJ = IIBAR(IJPROJ)
2404
2405 * calculate nuclear potentials (common /DTNPOT/)
2406       CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
2407
2408 * initialize treatment for residual nuclei
2409       CALL DT_RESNCL(EPN,NLOOP,1)
2410
2411 * sample hadron/nucleus-nucleus interaction
2412       CALL DT_KKEVNT(KKMAT,IREJ1)
2413       IF (IREJ1.GT.0) THEN
2414          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKINC'
2415          GOTO 9999
2416       ENDIF
2417
2418       IF ((NPMASS.GT.1).OR.(NTMASS.GT.1)) THEN
2419
2420 * intranuclear cascade of final state particles for KTAUGE generations
2421 * of secondaries
2422          CALL DT_FOZOCA(LFZC,IREJ1)
2423          IF (IREJ1.GT.0) THEN
2424             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKINC'
2425             GOTO 9999
2426          ENDIF
2427
2428 * baryons unable to escape the nuclear potential are treated as
2429 * excited nucleons (ISTHKK=15,16)
2430          CALL DT_SCN4BA
2431
2432 * decay of resonances produced in intranuclear cascade processes
2433 **sr 15-11-95 should be obsolete
2434 C        IF (LFZC) CALL DT_DECAY1
2435
2436   101    CONTINUE
2437 * treatment of residual nuclei
2438          CALL DT_RESNCL(EPN,NLOOP,2)
2439
2440 * evaporation / fission / fragmentation
2441 * (if intranuclear cascade was sampled only)
2442          IF (LFZC) THEN
2443             CALL DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ1)
2444             IF (IREJ1.GT.1) GOTO 101
2445             IF (IREJ1.EQ.1) GOTO 100
2446          ENDIF
2447
2448       ENDIF
2449
2450 * rejection of unphysical configurations
2451 C     CALL DT_REJUCO(1,IREJ1)
2452 C     IF (IREJ1.GT.0) THEN
2453 C        IF (IOULEV(1).GT.0)
2454 C    &      WRITE(LOUT,*) 'rejected 3 in KKINC: too large x'
2455 C        GOTO 100
2456 C     ENDIF
2457
2458 * transform finale state into Lab.
2459       IFLAG = 2
2460       CALL DT_BEAMPR(WHAT,DUM,IFLAG)
2461       IF ((IFRAME.EQ.1).AND.(IFLAG.EQ.-1)) CALL DT_LT2LAB
2462
2463       IF (IPI0.EQ.1) CALL DT_DECPI0
2464
2465 C     IF (NEVHKK.EQ.5) CALL DT_EVTOUT(4)
2466
2467       RETURN
2468  9999 CONTINUE
2469       IREJ = 1
2470       RETURN
2471       END
2472
2473 *$ CREATE DT_DEFAUL.FOR
2474 *COPY DT_DEFAUL
2475 *
2476 *===defaul=============================================================*
2477 *
2478       SUBROUTINE DT_DEFAUL(EPN,PPN)
2479
2480 ************************************************************************
2481 * Variables are set to default values.                                 *
2482 * This version dated 8.5.95 is written by S. Roesler.                  *
2483 ************************************************************************
2484
2485       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2486       SAVE
2487       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
2488       PARAMETER (TWOPI  = 6.283185307179586454D+00)
2489
2490 * particle properties (BAMJET index convention)
2491       CHARACTER*8  ANAME
2492       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2493      &                IICH(210),IIBAR(210),K1(210),K2(210)
2494
2495 * nuclear potential
2496       LOGICAL LFERMI
2497       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
2498      &                EBINDP(2),EBINDN(2),EPOT(2,210),
2499      &                ETACOU(2),ICOUL,LFERMI
2500
2501 * interface HADRIN-DPM
2502       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
2503
2504 * central particle production, impact parameter biasing
2505       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
2506
2507 * properties of interacting particles
2508       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2509
2510 * properties of photon/lepton projectiles
2511       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2512
2513       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2514
2515 * emulsion treatment
2516       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2517      &                NCOMPO,IEMUL
2518
2519 * parameter for intranuclear cascade
2520       LOGICAL LPAULI
2521       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
2522
2523 * various options for treatment of partons (DTUNUC 1.x)
2524 * (chain recombination, Cronin,..)
2525       LOGICAL LCO2CR,LINTPT
2526       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
2527      &                LCO2CR,LINTPT
2528
2529 * threshold values for x-sampling (DTUNUC 1.x)
2530       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
2531      &                SSMIMQ,VVMTHR
2532
2533 * flags for input different options
2534       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2535       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
2536      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
2537
2538 * n-n cross section fluctuations
2539       PARAMETER (NBINS = 1000)
2540       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
2541
2542 * flags for particle decays
2543       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
2544      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
2545      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
2546
2547 * diquark-breaking mechanism
2548       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
2549
2550 * nucleon-nucleon event-generator
2551       CHARACTER*8 CMODEL
2552       LOGICAL LPHOIN
2553       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2554
2555 * flags for diffractive interactions (DTUNUC 1.x)
2556       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
2557
2558 * VDM parameter for photon-nucleus interactions
2559       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
2560
2561 * Glauber formalism: flags and parameters for statistics
2562       LOGICAL LPROD
2563       CHARACTER*8 CGLB
2564       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
2565
2566 * kinematical cuts for lepton-nucleus interactions
2567       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2568      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2569
2570 * flags for activated histograms
2571       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2572
2573 * cuts for variable energy runs
2574       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
2575
2576 * parameters for hA-diffraction
2577       COMMON /DTDIHA/ DIBETA,DIALPH
2578
2579 * LEPTO
2580       REAL RPPN
2581       COMMON /LEPTOI/ RPPN,LEPIN,INTER
2582
2583 * steering flags for qel neutrino scattering modules
2584       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
2585
2586 * event flag
2587       COMMON /DTEVNO/ NEVENT,ICASCA
2588
2589       DATA POTMES /0.002D0/
2590
2591 * common /DTNPOT/
2592       DO 10 I=1,2
2593          PFERMP(I) = ZERO
2594          PFERMN(I) = ZERO
2595          EBINDP(I) = ZERO
2596          EBINDN(I) = ZERO
2597          DO 11 J=1,210
2598             EPOT(I,J) = ZERO
2599    11    CONTINUE
2600 * nucleus independent meson potential
2601          EPOT(I,13) = POTMES
2602          EPOT(I,14) = POTMES
2603          EPOT(I,15) = POTMES
2604          EPOT(I,16) = POTMES
2605          EPOT(I,23) = POTMES
2606          EPOT(I,24) = POTMES
2607          EPOT(I,25) = POTMES
2608    10 CONTINUE
2609       FERMOD    = 0.55D0
2610       ETACOU(1) = ZERO
2611       ETACOU(2) = ZERO
2612       ICOUL     = 1
2613       LFERMI    = .TRUE.
2614
2615 * common /HNTHRE/
2616       EHADTH = -99.0D0
2617       EHADLO = 4.06D0
2618       EHADHI = 6.0D0
2619       INTHAD = 1
2620       IDXTA  = 2
2621
2622 * common /DTIMPA/
2623       ICENTR = 0
2624       BIMIN  = ZERO
2625       BIMAX  = 1.0D10
2626       XSFRAC = 1.0D0
2627
2628 * common /DTPRTA/
2629       IP  = 1
2630       IPZ = 1
2631       IT  = 1
2632       ITZ = 1
2633       IJPROJ = 1
2634       IBPROJ = 1
2635       IJTARG = 1
2636       IBTARG = 1
2637 * common /DTGPRO/
2638       VIRT = ZERO
2639       DO 14 I=1,4
2640          PGAMM(I)  = ZERO
2641          PLEPT0(I) = ZERO
2642          PLEPT1(I) = ZERO
2643          PNUCL(I)  = ZERO
2644    14 CONTINUE
2645       IDIREC   = 0
2646
2647 * common /DTFOTI/
2648 **sr 7.4.98: changed after corrected B-sampling
2649 C     TAUFOR = 4.4D0
2650       TAUFOR = 3.5D0
2651       KTAUGE = 25
2652       ITAUVE = 1
2653       INCMOD = 1
2654       LPAULI = .TRUE.
2655
2656 * common /DTCHAI/
2657       SEASQ  = ONE
2658       MKCRON = 1
2659       CRONCO = 0.64D0
2660       ISICHA = 0
2661       CUTOF  = 100.0D0
2662       LCO2CR = .FALSE.
2663       IRECOM = 1
2664       LINTPT = .TRUE.
2665
2666 * common /DTXCUT/
2667 *  definition of soft quark distributions
2668       XSEACU = 0.05D0
2669       UNON   = 2.0D0
2670       UNOM   = 1.5D0
2671       UNOSEA = 5.0D0
2672 *  cutoff parameters for x-sampling
2673       CVQ    = 1.0D0
2674       CDQ    = 2.0D0
2675 C     CSEA   = 0.3D0
2676       CSEA   = 0.1D0
2677       SSMIMA = 1.2D0
2678       SSMIMQ = SSMIMA**2
2679       VVMTHR = 2.0D0
2680
2681 * common /DTXSFL/
2682       IFLUCT = 0
2683
2684 * common /DTFRPA/
2685       PDB = 0.15D0
2686       PDBSEA(1) = 0.0D0
2687       PDBSEA(2) = 0.0D0
2688       PDBSEA(3) = 0.0D0
2689       ISIG0 = 0
2690       IPI0  = 0
2691       NMSTU = 0
2692       NPARU = 0
2693       NMSTJ = 0
2694       NPARJ = 0
2695
2696 * common /DTDIQB/
2697       DO 15 I=1,8
2698          DBRKR(1,I) = 5.0D0
2699          DBRKR(2,I) = 5.0D0
2700          DBRKR(3,I) = 10.0D0
2701          DBRKA(1,I) = ZERO
2702          DBRKA(2,I) = ZERO
2703          DBRKA(3,I) = ZERO
2704    15 CONTINUE
2705       CHAM1 = 0.2D0
2706       CHAM3 = 0.5D0
2707       CHAB1 = 0.7D0
2708       CHAB3 = 1.0D0
2709
2710 * common /DTFLG3/
2711       ISINGD = 0
2712       IDOUBD = 0
2713       IFLAGD = 0
2714       IDIFF  = 0
2715
2716 * common /DTMODL/
2717       MCGENE    = 2
2718       CMODEL(1) = 'DTUNUC  '
2719       CMODEL(2) = 'PHOJET  '
2720       CMODEL(3) = 'LEPTO   '
2721       CMODEL(4) = 'QNEUTRIN'
2722       LPHOIN    = .TRUE.
2723       ELOJET    = 5.0D0
2724
2725 * common /DTLCUT/
2726       ECMIN  = 3.5D0
2727       ECMAX  = 1.0D10
2728       XBJMIN = ZERO
2729       ELMIN = ZERO
2730       EGMIN = ZERO
2731       EGMAX = 1.0D10
2732       YMIN  = TINY10
2733       YMAX  = 0.999D0
2734       Q2MIN = TINY10
2735       Q2MAX = 10.0D0
2736       THMIN = ZERO
2737       THMAX = TWOPI
2738       Q2LI  = ZERO
2739       Q2HI  = 1.0D10
2740       ECMLI = ZERO
2741       ECMHI = 1.0D10
2742
2743 * common /DTVDMP/
2744       RL2       = 2.0D0
2745       INTRGE(1) = 1
2746       INTRGE(2) = 3
2747       IDPDF     = 2212
2748       MODEGA    = 4
2749       ISHAD(1)  = 1
2750       ISHAD(2)  = 1
2751       ISHAD(3)  = 1
2752       EPSPOL    = ZERO
2753
2754 * common /DTGLGP/
2755       JSTATB = 1000
2756       JBINSB = 49
2757       CGLB   = '        '
2758       IF (ITRSPT.EQ.1) THEN
2759          IOGLB  = 100
2760       ELSE
2761          IOGLB  = 0
2762       ENDIF
2763       LPROD  = .TRUE.
2764
2765 * common /DTHIS3/
2766       DO 16 I=1,50
2767          IHISPP(I) = 0
2768          IHISXS(I) = 0
2769    16 CONTINUE
2770       IXSTBL = 0
2771
2772 * common /DTVARE/
2773       VARELO = ZERO
2774       VAREHI = ZERO
2775       VARCLO = ZERO
2776       VARCHI = ZERO
2777
2778 * common /DTDIHA/
2779       DIBETA = -1.0D0
2780       DIALPH = ZERO
2781
2782 * common /LEPTOI/
2783       RPPN  = 0.0
2784       LEPIN = 0
2785       INTER = 0
2786
2787 * common /QNEUTO/
2788       NEUTYP = 1
2789       NEUDEC = 0
2790
2791 * common /DTEVNO/
2792       NEVENT = 1
2793       IF (ITRSPT.EQ.1) THEN
2794          ICASCA = 1
2795       ELSE
2796          ICASCA = 0
2797       ENDIF
2798
2799 * default Lab.-energy
2800       EPN = 200.0D0
2801       PPN = SQRT((EPN-AAM(IJPROJ))*(EPN+AAM(IJPROJ)))
2802
2803       RETURN
2804       END
2805
2806 *$ CREATE DT_AAEVT.FOR
2807 *COPY DT_AAEVT
2808 *
2809 *===aaevt==============================================================*
2810 *
2811       SUBROUTINE DT_AAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2812      &                                             IDP,IGLAU)
2813
2814 ************************************************************************
2815 * This version dated 22.03.96 is written by S. Roesler.                *
2816 ************************************************************************
2817
2818       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2819       SAVE
2820
2821       PARAMETER ( LINP = 10 ,
2822      &            LOUT = 6 ,
2823      &            LDAT = 9 )
2824
2825       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2826
2827 * emulsion treatment
2828       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2829      &                NCOMPO,IEMUL
2830
2831 * event flag
2832       COMMON /DTEVNO/ NEVENT,ICASCA
2833
2834       CHARACTER*8 DATE,HHMMSS
2835       CHARACTER*9 CHDATE,CHTIME,CHZONE
2836       DIMENSION JDMNYR(8),IDMNYR(3)
2837
2838       KKMAT  = 1
2839       NMSG   = MAX(NEVTS/100,1)
2840
2841 * initialization of run-statistics and histograms
2842       CALL DT_STATIS(1)
2843
2844       CALL PHO_PHIST(1000,DUM)
2845
2846 * initialization of Glauber-formalism
2847       IF (NCOMPO.LE.0) THEN
2848          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
2849       ELSE
2850          DO 1 I=1,NCOMPO
2851             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
2852     1    CONTINUE
2853       ENDIF
2854       CALL DT_SIGEMU
2855
2856 C     CALL IDATE(IDMNYR)
2857 C     WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2858 C    &   IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2859       CALL DATE_AND_TIME ( CHDATE, CHTIME, CHZONE, JDMNYR )
2860       WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2861      &   JDMNYR(3),JDMNYR(2),MOD(JDMNYR(1),100)
2862       CALL ITIME(IDMNYR)
2863       WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2864      &   IDMNYR(1),IDMNYR(2),IDMNYR(3)
2865       WRITE(LOUT,1001) DATE,HHMMSS
2866  1001 FORMAT(/,' DT_AAEVT: Initialisation finished. ( Date: ',A8,
2867      &       '   Time: ',A8,' )')
2868
2869 * generate NEVTS events
2870       DO 2 IEVT=1,NEVTS
2871
2872 *  print run-status message
2873          IF (MOD(IEVT,NMSG).EQ.0) THEN
2874 C           CALL IDATE(IDMNYR)
2875 C           WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2876 C    &         IDMNYR(1),IDMNYR(2),MOD(IDMNYR(3),100)
2877             CALL DATE_AND_TIME ( CHDATE, CHTIME, CHZONE, JDMNYR )
2878             WRITE(DATE,'(I2,''/'',I2,''/'',I2)')
2879      &         JDMNYR(3),JDMNYR(2),MOD(JDMNYR(1),100)
2880             CALL ITIME(IDMNYR)
2881             WRITE(HHMMSS,'(I2,'':'',I2,'':'',I2)')
2882      &         IDMNYR(1),IDMNYR(2),IDMNYR(3)
2883             WRITE(LOUT,1000) IEVT-1,NEVTS,DATE,HHMMSS
2884  1000       FORMAT(/,1X,I8,' out of ',I8,' events sampled ( Date: ',A,
2885      &             '   Time: ',A,' )',/)
2886 C           WRITE(LOUT,1000) IEVT-1
2887 C1000       FORMAT(1X,I8,' events sampled')
2888          ENDIF
2889          NEVENT = IEVT
2890 *  treat nuclear emulsions
2891          IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
2892 *  composite targets only
2893          KKMAT = -KKMAT
2894 *  sample this event
2895          CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,KKMAT,IREJ)
2896
2897          CALL PHO_PHIST(2000,DUM)
2898
2899     2 CONTINUE
2900
2901 * print run-statistics and histograms to output-unit 6
2902
2903       CALL PHO_PHIST(3000,DUM)
2904
2905       CALL DT_STATIS(2)
2906
2907       RETURN
2908       END
2909
2910 *$ CREATE DT_LAEVT.FOR
2911 *COPY DT_LAEVT
2912 *
2913 *===laevt==============================================================*
2914 *
2915       SUBROUTINE DT_LAEVT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
2916      &                                             IDP,IGLAU)
2917
2918 ************************************************************************
2919 * Interface to run DPMJET for lepton-nucleus interactions.             *
2920 * Kinematics is sampled using the equivalent photon approximation      *
2921 * Based on GPHERA-routine by R. Engel.                                 *
2922 * This version dated 23.03.96 is written by S. Roesler.                *
2923 ************************************************************************
2924
2925       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
2926       SAVE
2927
2928       PARAMETER ( LINP = 10 ,
2929      &            LOUT = 6 ,
2930      &            LDAT = 9 )
2931
2932       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,
2933      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
2934       PARAMETER (TWOPI  = 6.283185307179586454D+00,
2935      &           PI     = TWOPI/TWO,
2936      &           ALPHEM = ONE/137.0D0)
2937
2938 C     CHARACTER*72 HEADER
2939
2940 * particle properties (BAMJET index convention)
2941       CHARACTER*8  ANAME
2942       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
2943      &                IICH(210),IIBAR(210),K1(210),K2(210)
2944
2945 * event history
2946
2947       PARAMETER (NMXHKK=200000)
2948
2949       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
2950      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
2951      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
2952
2953 * extended event history
2954       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
2955      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
2956      &                IHIST(2,NMXHKK)
2957
2958 * kinematical cuts for lepton-nucleus interactions
2959       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
2960      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
2961
2962 * properties of interacting particles
2963       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
2964
2965 * properties of photon/lepton projectiles
2966       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
2967
2968 * kinematics at lepton-gamma vertex
2969       COMMON /DTLGVX/ PPL0(4),PPL1(4),PPG(4),PPA(4)
2970
2971 * flags for activated histograms
2972       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
2973
2974       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
2975
2976 * emulsion treatment
2977       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
2978      &                NCOMPO,IEMUL
2979
2980 * Glauber formalism: cross sections
2981       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
2982      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
2983      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
2984      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
2985      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
2986      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
2987      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
2988      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
2989      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
2990      &                BSLOPE,NEBINI,NQBINI
2991
2992 * nucleon-nucleon event-generator
2993       CHARACTER*8 CMODEL
2994       LOGICAL LPHOIN
2995       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
2996
2997 * flags for input different options
2998       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
2999       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3000      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3001
3002 * event flag
3003       COMMON /DTEVNO/ NEVENT,ICASCA
3004
3005       DIMENSION XDUMB(40),BGTA(4)
3006
3007 * LEPTO
3008       IF (MCGENE.EQ.3) THEN
3009
3010          STOP ' This version does not contain LEPTO !'
3011
3012       ENDIF
3013
3014       KKMAT  = 1
3015       NMSG   = MAX(NEVTS/10,1)
3016
3017 * mass of incident lepton
3018       AMLPT  = AAM(IDP)
3019       AMLPT2 = AMLPT**2
3020       IDPPDG = IDT_IPDGHA(IDP)
3021
3022 * consistency of kinematical limits
3023       Q2MIN  = MAX(Q2MIN,TINY10)
3024       Q2MAX  = MAX(Q2MAX,TINY10)
3025       YMIN   = MIN(MAX(YMIN,TINY10),0.999D0)
3026       YMAX   = MIN(MAX(YMAX,TINY10),0.999D0)
3027
3028 * total energy of the lepton-nucleon system
3029       PTOTLN = SQRT( (PLEPT0(1)+PNUCL(1))**2+(PLEPT0(2)+PNUCL(2))**2
3030      &                                      +(PLEPT0(3)+PNUCL(3))**2 )
3031       ETOTLN = PLEPT0(4)+PNUCL(4)
3032       ECMLN  = SQRT((ETOTLN-PTOTLN)*(ETOTLN+PTOTLN))
3033       ECMAX  = MIN(ECMAX,ECMLN)
3034       WRITE(LOUT,1003) ECMIN,ECMAX,YMIN,YMAX,Q2MIN,Q2MAX,EGMIN,
3035      &                 THMIN,THMAX,ELMIN
3036  1003 FORMAT(1X,'LAEVT:',16X,'kinematical cuts',/,22X,
3037      &       '------------------',/,9X,'W (min)   =',
3038      &       F7.1,' GeV    (max) =',F7.1,' GeV',/,9X,'y (min)   =',
3039      &       F7.3,8X,'(max) =',F7.3,/,9X,'Q^2 (min) =',F7.1,
3040      &       ' GeV^2  (max) =',F7.1,' GeV^2',/,' (Lab)   E_g (min) ='
3041      &       ,F7.1,' GeV',/,' (Lab) theta (min) =',F7.4,8X,'(max) =',
3042      &       F7.4,'   for E_lpt >',F7.1,' GeV',/)
3043
3044 * Lorentz-parameter for transf. into Lab
3045       BGTA(1) = PNUCL(1)/AAM(1)
3046       BGTA(2) = PNUCL(2)/AAM(1)
3047       BGTA(3) = PNUCL(3)/AAM(1)
3048       BGTA(4) = PNUCL(4)/AAM(1)
3049 * LT of incident lepton into Lab and dump it in DTEVT1
3050       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3051      &            PLEPT0(1),PLEPT0(2),PLEPT0(3),PLEPT0(4),
3052      &            PLTOT,PPL0(1),PPL0(2),PPL0(3),PPL0(4))
3053       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3054      &            PNUCL(1),PNUCL(2),PNUCL(3),PNUCL(4),
3055      &            PLTOT,PPA(1),PPA(2),PPA(3),PPA(4))
3056 * maximum energy of photon nucleon system
3057       PTOTGN = SQRT((YMAX*PPL0(1)+PPA(1))**2+(YMAX*PPL0(2)+PPA(2))**2
3058      &                                      +(YMAX*PPL0(3)+PPA(3))**2)
3059       ETOTGN = YMAX*PPL0(4)+PPA(4)
3060       EGNMAX = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
3061       EGNMAX = MIN(EGNMAX,ECMAX)
3062 * minimum energy of photon nucleon system
3063       PTOTGN = SQRT((YMIN*PPL0(1)+PPA(1))**2+(YMIN*PPL0(2)+PPA(2))**2
3064      &                                      +(YMIN*PPL0(3)+PPA(3))**2)
3065       ETOTGN = YMIN*PPL0(4)+PPA(4)
3066       EGNMIN = SQRT((ETOTGN-PTOTGN)*(ETOTGN+PTOTGN))
3067       EGNMIN = MAX(EGNMIN,ECMIN)
3068
3069 * limits for Glauber-initialization
3070       Q2LI  = Q2MIN
3071       Q2HI  = MAX(Q2LI,MIN(Q2HI,Q2MAX))
3072       ECMLI = MAX(EGNMIN,THREE)
3073       ECMHI = EGNMAX
3074       WRITE(LOUT,1004) EGNMIN,EGNMAX,ECMLI,ECMHI,Q2LI,Q2HI
3075  1004 FORMAT(1X,'resulting limits:',/,9X,'W (min)   =',F7.1,
3076      &       ' GeV    (max) =',F7.1,' GeV',/,/,' limits for ',
3077      &       'Glauber-initialization:',/,9X,'W (min)   =',F7.1,
3078      &       ' GeV    (max) =',F7.1,' GeV',/,9X,'Q^2 (min) =',F7.1,
3079      &       ' GeV^2  (max) =',F7.1,' GeV^2',/)
3080 * initialization of Glauber-formalism
3081       IF (NCOMPO.LE.0) THEN
3082          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3083       ELSE
3084          DO 9 I=1,NCOMPO
3085             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3086     9    CONTINUE
3087       ENDIF
3088       CALL DT_SIGEMU
3089
3090 * initialization of run-statistics and histograms
3091       CALL DT_STATIS(1)
3092
3093       CALL PHO_PHIST(1000,DUM)
3094
3095 * maximum photon-nucleus cross section
3096       I1  = 1
3097       I2  = 1
3098       RAT = ONE
3099       IF (EGNMAX.GE.ECMNN(NEBINI)) THEN
3100          I1  = NEBINI
3101          I2  = NEBINI
3102          RAT = ONE
3103       ELSEIF (EGNMAX.GT.ECMNN(1)) THEN
3104          DO 5 I=2,NEBINI
3105             IF (EGNMAX.LT.ECMNN(I)) THEN
3106                I1  = I-1
3107                I2  = I
3108                RAT = (EGNMAX-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
3109                GOTO 6
3110             ENDIF
3111     5    CONTINUE
3112     6    CONTINUE
3113       ENDIF
3114       SIGMAX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
3115       EGNXX  = EGNMAX
3116       I1  = 1
3117       I2  = 1
3118       RAT = ONE
3119       IF (EGNMIN.GE.ECMNN(NEBINI)) THEN
3120          I1  = NEBINI
3121          I2  = NEBINI
3122          RAT = ONE
3123       ELSEIF (EGNMIN.GT.ECMNN(1)) THEN
3124          DO 7 I=2,NEBINI
3125             IF (EGNMIN.LT.ECMNN(I)) THEN
3126                I1  = I-1
3127                I2  = I
3128                RAT = (EGNMIN-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
3129                GOTO 8
3130             ENDIF
3131     7    CONTINUE
3132     8    CONTINUE
3133       ENDIF
3134       SIGXX = XSTOT(I1,1,1)+RAT*(XSTOT(I2,1,1)-XSTOT(I1,1,1))
3135       IF (SIGXX.GT.SIGMAX) EGNXX = EGNMIN
3136       SIGMAX = MAX(SIGMAX,SIGXX)
3137       WRITE(LOUT,'(9X,A,F8.3,A)') 'Sigma_tot (max) =',SIGMAX,' mb'
3138
3139 * plot photon flux table
3140       AYMIN = LOG(YMIN)
3141       AYMAX = LOG(YMAX)
3142       AYRGE = AYMAX-AYMIN
3143       MAXTAB = 50
3144       ADY    = LOG(YMAX/YMIN)/DBLE(MAXTAB-1)
3145 C     WRITE(LOUT,'(/,1X,A)') 'LAEVT:   photon flux '
3146       DO 1 I=1,MAXTAB
3147          Y     = EXP(AYMIN+ADY*DBLE(I-1))
3148          Q2LOW = MAX(Q2MIN,AMLPT2*Y**2/(ONE-Y))
3149          FF1   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
3150      &                           -TWO*AMLPT2*Y*(ONE/Q2LOW-ONE/Q2MAX))
3151          FF2   = ALPHEM/TWOPI * ((ONE+(ONE-Y)**2)/Y*LOG(Q2MAX/Q2LOW)
3152      &                           -TWO*(ONE-Y)/Y*(ONE-Q2LOW/Q2MAX))
3153 C        WRITE(LOUT,'(5X,3E15.4)') Y,FF1,FF2
3154     1 CONTINUE
3155
3156 * maximum residual weight for flux sampling (dy/y)
3157       YY     = YMIN
3158       Q2LOW  = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
3159       WGHMAX = (ONE+(ONE-YY)**2)*LOG(Q2MAX/Q2LOW)
3160      &         -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
3161
3162       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY0)
3163       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY1)
3164       CALL DT_NEWHGR(YMIN,YMAX,ZERO,XDUMB,49,IHFLY2)
3165       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ0)
3166       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ1)
3167       CALL DT_NEWHGR(Q2LOW,Q2MAX,ZERO,XDUMB,20,IHFLQ2)
3168       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE0)
3169       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE1)
3170       CALL DT_NEWHGR(EGNMIN,EGNMAX,ZERO,XDUMB,20,IHFLE2)
3171       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU0)
3172       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU1)
3173       CALL DT_NEWHGR(ZERO,EGMAX,ZERO,XDUMB,20,IHFLU2)
3174       XBLOW = 0.001D0
3175       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX0)
3176       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX1)
3177       CALL DT_NEWHGR(XBLOW,ONE,ZERO,XDUMB,-40,IHFLX2)
3178
3179       ITRY = 0
3180       ITRW = 0
3181       NC0  = 0
3182       NC1  = 0
3183
3184 * generate events
3185       DO 2 IEVT=1,NEVTS
3186          IF (MOD(IEVT,NMSG).EQ.0) THEN
3187 C           OPEN(LDAT,FILE='/scrtch3/hr/sroesler/statusd5.out',
3188 C    &                                         STATUS='UNKNOWN')
3189             WRITE(LOUT,'(1X,I8,A)') IEVT-1,' events sampled'
3190 C           CLOSE(LDAT)
3191          ENDIF
3192          NEVENT = IEVT
3193
3194   100    CONTINUE
3195          ITRY = ITRY+1
3196
3197 *  sample y
3198   101    CONTINUE
3199          ITRW  = ITRW+1
3200          YY    = EXP(AYRGE*DT_RNDM(RAT)+AYMIN)
3201          Q2LOW = MAX(Q2MIN,AMLPT2*YY**2/(ONE-YY))
3202          Q2LOG = LOG(Q2MAX/Q2LOW)
3203          WGH   = (ONE+(ONE-YY)**2)*Q2LOG
3204      &           -TWO*AMLPT2*YY*(ONE/Q2LOW-ONE/Q2MAX)*YY
3205          IF (WGHMAX.LT.WGH) WRITE(LOUT,1000) YY,WGHMAX,WGH
3206  1000    FORMAT(1X,'LAEVT:   weight error!',3E12.5)
3207          IF (DT_RNDM(YY)*WGHMAX.GT.WGH) GOTO 101
3208
3209 *  sample Q2
3210          YEFF = ONE+(ONE-YY)**2
3211   102    CONTINUE
3212          Q2  = Q2LOW*EXP(Q2LOG*DT_RNDM(YY))
3213          WGH = (YEFF-TWO*(ONE-YY)*Q2LOW/Q2)/YEFF
3214          IF (WGH.LT.DT_RNDM(Q2)) GOTO 102
3215
3216 c        NC0 = NC0+1
3217 c        CALL DT_FILHGR(YY,ONE,IHFLY0,NC0)
3218 c        CALL DT_FILHGR(Q2,ONE,IHFLQ0,NC0)
3219
3220 *  kinematics at lepton-photon vertex
3221 *   scattered electron
3222          YQ2 = SQRT((ONE-YY)*Q2)
3223          Q2E = Q2/(4.0D0*PLEPT0(4))
3224          E1Y = (ONE-YY)*PLEPT0(4)
3225          CALL DT_DSFECF(SIF,COF)
3226          PLEPT1(1) = YQ2*COF
3227          PLEPT1(2) = YQ2*SIF
3228          PLEPT1(3) = E1Y-Q2E
3229          PLEPT1(4) = E1Y+Q2E
3230 C        THETA = ACOS( (E1Y-Q2E)/(E1Y+Q2E) )
3231 *   radiated photon
3232          PGAMM(1) = -PLEPT1(1)
3233          PGAMM(2) = -PLEPT1(2)
3234          PGAMM(3) = PLEPT0(3)-PLEPT1(3)
3235          PGAMM(4) = PLEPT0(4)-PLEPT1(4)
3236 *   E_cm cut
3237          PTOTGN = SQRT( (PGAMM(1)+PNUCL(1))**2+(PGAMM(2)+PNUCL(2))**2
3238      &                                        +(PGAMM(3)+PNUCL(3))**2 )
3239          ETOTGN = PGAMM(4)+PNUCL(4)
3240          ECMGN  = (ETOTGN-PTOTGN)*(ETOTGN+PTOTGN)
3241          IF (ECMGN.LT.0.1D0) GOTO 101
3242          ECMGN  = SQRT(ECMGN)
3243          IF ((ECMGN.LT.ECMIN).OR.(ECMGN.GT.ECMAX)) GOTO 101
3244
3245 *  Lorentz-transformation into nucleon-rest system
3246          CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3247      &               PGAMM(1),PGAMM(2),PGAMM(3),PGAMM(4),
3248      &               PGTOT,PPG(1),PPG(2),PPG(3),PPG(4))
3249          CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
3250      &               PLEPT1(1),PLEPT1(2),PLEPT1(3),PLEPT1(4),
3251      &               PLTOT,PPL1(1),PPL1(2),PPL1(3),PPL1(4))
3252 *  temporary checks..
3253          Q2TMP = ABS(PPG(4)**2-PGTOT**2)
3254          IF (ABS(Q2-Q2TMP).GT.0.01D0) WRITE(LOUT,1001) Q2,Q2TMP
3255  1001    FORMAT(1X,'LAEVT:    inconsistent kinematics (Q2,Q2TMP) ',
3256      &          2F10.4)
3257          ECMTMP = SQRT((PPG(4)+AAM(1)-PGTOT)*(PPG(4)+AAM(1)+PGTOT))
3258          IF (ABS(ECMGN-ECMTMP).GT.TINY10) WRITE(LOUT,1002) ECMGN,ECMTMP
3259  1002    FORMAT(1X,'LAEVT:    inconsistent kinematics (ECMGN,ECMTMP) ',
3260      &          2F10.2)
3261          YYTMP = PPG(4)/PPL0(4)
3262          IF (ABS(YY-YYTMP).GT.0.01D0) WRITE(LOUT,1005) YY,YYTMP
3263  1005    FORMAT(1X,'LAEVT:    inconsistent kinematics (YY,YYTMP) ',
3264      &          2F10.4)
3265
3266 *  lepton tagger (Lab)
3267          THETA = ACOS( PPL1(3)/PLTOT )
3268          IF (PPL1(4).GT.ELMIN) THEN
3269             IF ((THETA.LT.THMIN).OR.(THETA.GT.THMAX)) GOTO 101
3270          ENDIF
3271 *  photon energy-cut (Lab)
3272          IF (PPG(4).LT.EGMIN) GOTO 101
3273          IF (PPG(4).GT.EGMAX) GOTO 101
3274 *   x_Bj cut
3275          XBJ = ABS(Q2/(1.876D0*PPG(4)))
3276          IF (XBJ.LT.XBJMIN) GOTO 101
3277
3278          NC0 = NC0+1
3279          CALL DT_FILHGR(    Q2,ONE,IHFLQ0,NC0)
3280          CALL DT_FILHGR(    YY,ONE,IHFLY0,NC0)
3281          CALL DT_FILHGR(   XBJ,ONE,IHFLX0,NC0)
3282          CALL DT_FILHGR(PPG(4),ONE,IHFLU0,NC0)
3283          CALL DT_FILHGR( ECMGN,ONE,IHFLE0,NC0)
3284
3285 *  rotation angles against z-axis
3286          COD = PPG(3)/PGTOT
3287 C        SID = SQRT((ONE-COD)*(ONE+COD))
3288          PPT = SQRT(PPG(1)**2+PPG(2)**2)
3289          SID = PPT/PGTOT
3290          COF = ONE
3291          SIF = ZERO
3292          IF (PGTOT*SID.GT.TINY10) THEN
3293             COF   = PPG(1)/(SID*PGTOT)
3294             SIF   = PPG(2)/(SID*PGTOT)
3295             ANORF = SQRT(COF*COF+SIF*SIF)
3296             COF   = COF/ANORF
3297             SIF   = SIF/ANORF
3298          ENDIF
3299
3300          IF (IXSTBL.EQ.0) THEN
3301 *  change to photon projectile
3302             IJPROJ = 7
3303 *  set virtuality
3304             VIRT = Q2
3305 *  re-initialize LTs with new kinematics
3306 *  !!PGAMM ist set in cms (ECMGN) along z
3307             EPN = ZERO
3308             PPN = ZERO
3309             CALL DT_LTINI(IJPROJ,IJTARG,EPN,PPN,ECMGN,0)
3310 *  force Lab-system
3311             IFRAME = 1
3312 *  get emulsion component if requested
3313             IF (IEMUL.GT.0) CALL DT_GETEMU(NTMASS,NTCHAR,KKMAT,0)
3314 *  convolute with cross section
3315             CALL DT_SIGGAT(Q2LOW,EGNXX,STOTX,KKMAT)
3316             CALL DT_SIGGAT(Q2,ECMGN,STOT,KKMAT)
3317             IF (STOTX.LT.STOT) WRITE(LOUT,'(1X,A,/,6E12.3)')
3318      &         'LAEVT: warning STOTX<STOT ! ',Q2LOW,EGNMAX,STOTX,
3319      &                                        Q2,ECMGN,STOT
3320             IF (DT_RNDM(Q2)*STOTX.GT.STOT) GOTO 100
3321             NC1 = NC1+1
3322             CALL DT_FILHGR(    Q2,ONE,IHFLQ1,NC1)
3323             CALL DT_FILHGR(    YY,ONE,IHFLY1,NC1)
3324             CALL DT_FILHGR(   XBJ,ONE,IHFLX1,NC1)
3325             CALL DT_FILHGR(PPG(4),ONE,IHFLU1,NC1)
3326             CALL DT_FILHGR( ECMGN,ONE,IHFLE1,NC1)
3327 *  composite targets only
3328             KKMAT = -KKMAT
3329 *  sample this event
3330             CALL DT_KKINC(NPMASS,NPCHAR,NTMASS,NTCHAR,IJPROJ,EPN,KKMAT,
3331      &                                                            IREJ)
3332 *  rotate momenta of final state particles back in photon-nucleon syst.
3333             DO 4 I=NPOINT(4),NHKK
3334                IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3335      &                                      (ISTHKK(I).EQ.1001)) THEN
3336                   PX = PHKK(1,I)
3337                   PY = PHKK(2,I)
3338                   PZ = PHKK(3,I)
3339                   CALL DT_MYTRAN(1,PX,PY,PZ,COD,SID,COF,SIF,
3340      &                        PHKK(1,I),PHKK(2,I),PHKK(3,I))
3341                ENDIF
3342     4       CONTINUE
3343          ENDIF
3344
3345          CALL DT_FILHGR(    Q2,ONE,IHFLQ2,NC1)
3346          CALL DT_FILHGR(    YY,ONE,IHFLY2,NC1)
3347          CALL DT_FILHGR(   XBJ,ONE,IHFLX2,NC1)
3348          CALL DT_FILHGR(PPG(4),ONE,IHFLU2,NC1)
3349          CALL DT_FILHGR( ECMGN,ONE,IHFLE2,NC1)
3350
3351 *  dump this event to histograms
3352
3353          CALL PHO_PHIST(2000,DUM)
3354
3355     2 CONTINUE
3356
3357       WGY    = ALPHEM/TWOPI*WGHMAX*DBLE(ITRY)/DBLE(ITRW)
3358       WGY    = WGY*LOG(YMAX/YMIN)
3359       WEIGHT = WGY*SIGMAX*DBLE(NEVTS)/DBLE(ITRY)
3360
3361 C     HEADER = ' LAEVT:  Q^2 distribution 0'
3362 C     CALL DT_OUTHGR(IHFLQ0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3363 C     HEADER = ' LAEVT:  Q^2 distribution 1'
3364 C     CALL DT_OUTHGR(IHFLQ1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3365 C     HEADER = ' LAEVT:  Q^2 distribution 2'
3366 C     CALL DT_OUTHGR(IHFLQ2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3367 C     HEADER = ' LAEVT:  y   distribution 0'
3368 C     CALL DT_OUTHGR(IHFLY0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3369 C     HEADER = ' LAEVT:  y   distribution 1'
3370 C     CALL DT_OUTHGR(IHFLY1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3371 C     HEADER = ' LAEVT:  y   distribution 2'
3372 C     CALL DT_OUTHGR(IHFLY2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3373 C     HEADER = ' LAEVT:  x   distribution 0'
3374 C     CALL DT_OUTHGR(IHFLX0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3375 C     HEADER = ' LAEVT:  x   distribution 1'
3376 C     CALL DT_OUTHGR(IHFLX1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3377 C     HEADER = ' LAEVT:  x   distribution 2'
3378 C     CALL DT_OUTHGR(IHFLX2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3379 C     HEADER = ' LAEVT:  E_g distribution 0'
3380 C     CALL DT_OUTHGR(IHFLU0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3381 C     HEADER = ' LAEVT:  E_g distribution 1'
3382 C     CALL DT_OUTHGR(IHFLU1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3383 C     HEADER = ' LAEVT:  E_g distribution 2'
3384 C     CALL DT_OUTHGR(IHFLU2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3385 C     HEADER = ' LAEVT:  E_c distribution 0'
3386 C     CALL DT_OUTHGR(IHFLE0,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3387 C     HEADER = ' LAEVT:  E_c distribution 1'
3388 C     CALL DT_OUTHGR(IHFLE1,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3389 C     HEADER = ' LAEVT:  E_c distribution 2'
3390 C     CALL DT_OUTHGR(IHFLE2,0,0,0,0,0,HEADER,0,NEVTS,ONE,1,1,-1)
3391
3392 * print run-statistics and histograms to output-unit 6
3393
3394       CALL PHO_PHIST(3000,DUM)
3395
3396       IF (IXSTBL.EQ.0) CALL DT_STATIS(2)
3397
3398       RETURN
3399       END
3400
3401 *$ CREATE DT_DTUINI.FOR
3402 *COPY DT_DTUINI
3403 *
3404 *===dtuini=============================================================*
3405 *
3406       SUBROUTINE DT_DTUINI(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,
3407      &                                               IDP,IEMU)
3408
3409       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3410       SAVE
3411
3412       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
3413
3414 * emulsion treatment
3415       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
3416      &                NCOMPO,IEMUL
3417
3418 * Glauber formalism: flags and parameters for statistics
3419       LOGICAL LPROD
3420       CHARACTER*8 CGLB
3421       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
3422
3423       CALL DT_INIT(NEVTS,EPN,NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,IGLAU)
3424       CALL DT_STATIS(1)
3425
3426       CALL PHO_PHIST(1000,DUM)
3427
3428       IF (NCOMPO.LE.0) THEN
3429          CALL DT_SHMAKI(NPMASS,NPCHAR,NTMASS,NTCHAR,IDP,EPN,IGLAU)
3430       ELSE
3431          DO 1 I=1,NCOMPO
3432             CALL DT_SHMAKI(NPMASS,NPCHAR,IEMUMA(I),IEMUCH(I),IDP,EPN,0)
3433     1    CONTINUE
3434       ENDIF
3435       IF (IOGLB.NE.100) CALL DT_SIGEMU
3436       IEMU = IEMUL
3437
3438       RETURN
3439       END
3440
3441 *$ CREATE DT_DTUOUT.FOR
3442 *COPY DT_DTUOUT
3443 *
3444 *===dtuout=============================================================*
3445 *
3446       SUBROUTINE DT_DTUOUT
3447
3448       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3449       SAVE
3450
3451       CALL PHO_PHIST(3000,DUM)
3452
3453       CALL DT_STATIS(2)
3454
3455       RETURN
3456       END
3457
3458 *$ CREATE DT_BEAMPR.FOR
3459 *COPY DT_BEAMPR
3460 *
3461 *===beampr=============================================================*
3462 *
3463       SUBROUTINE DT_BEAMPR(WHAT,PLAB,MODE)
3464
3465 ************************************************************************
3466 * Initialization of event generation                                   *
3467 * This version dated  7.4.98  is written by S. Roesler.                *
3468 ************************************************************************
3469
3470       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3471       SAVE
3472
3473       PARAMETER ( LINP = 10 ,
3474      &            LOUT = 6 ,
3475      &            LDAT = 9 )
3476
3477       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3478       PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3479
3480       LOGICAL LBEAM
3481
3482 * event history
3483
3484       PARAMETER (NMXHKK=200000)
3485
3486       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3487      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3488      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3489
3490 * extended event history
3491       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3492      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3493      &                IHIST(2,NMXHKK)
3494
3495 * properties of interacting particles
3496       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3497
3498 * particle properties (BAMJET index convention)
3499       CHARACTER*8  ANAME
3500       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3501      &                IICH(210),IIBAR(210),K1(210),K2(210)
3502
3503 * beam momenta
3504       COMMON /DTBEAM/ P1(4),P2(4)
3505
3506 C     DIMENSION WHAT(6),P1(4),P2(4),P1CMS(4),P2CMS(4)
3507       DIMENSION WHAT(6),P1CMS(4),P2CMS(4)
3508
3509       DATA LBEAM /.FALSE./
3510
3511       GOTO (1,2) MODE
3512
3513     1 CONTINUE
3514
3515       E1  = WHAT(1)
3516       IF (E1.LT.ZERO) E1 = DBLE(IPZ)/DBLE(IP)*ABS(WHAT(1))
3517       E2  = WHAT(2)
3518       IF (E2.LT.ZERO) E2 = DBLE(ITZ)/DBLE(IT)*ABS(WHAT(2))
3519       PP1 = SQRT( (E1+AAM(IJPROJ))*(E1-AAM(IJPROJ)) )
3520       PP2 = SQRT( (E2+AAM(IJTARG))*(E2-AAM(IJTARG)) )
3521       TH  = 1.D-6*WHAT(3)/2.D0
3522       PH  = WHAT(4)*BOG
3523       P1(1) = PP1*SIN(TH)*COS(PH)
3524       P1(2) = PP1*SIN(TH)*SIN(PH)
3525       P1(3) = PP1*COS(TH)
3526       P1(4) = E1
3527       P2(1) = PP2*SIN(TH)*COS(PH)
3528       P2(2) = PP2*SIN(TH)*SIN(PH)
3529       P2(3) = -PP2*COS(TH)
3530       P2(4) = E2
3531       ECM  = SQRT( (P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))**2
3532      &                                              -(P1(3)+P2(3))**2 )
3533       ELAB = (ECM**2-AAM(IJPROJ)**2-AAM(IJTARG)**2)/(2.0D0*AAM(IJTARG))
3534       PLAB = SQRT( (ELAB+AAM(IJPROJ))*(ELAB-AAM(IJPROJ)) )
3535       BGX  = (P1(1)+P2(1))/ECM
3536       BGY  = (P1(2)+P2(2))/ECM
3537       BGZ  = (P1(3)+P2(3))/ECM
3538       BGE  = (P1(4)+P2(4))/ECM
3539       CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P1(1),P1(2),P1(3),P1(4),
3540      &            P1TOT,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4))
3541       CALL DT_DALTRA(BGE,-BGX,-BGY,-BGZ,P2(1),P2(2),P2(3),P2(4),
3542      &            P2TOT,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4))
3543       COD = P1CMS(3)/P1TOT
3544 C     SID = SQRT((ONE-COD)*(ONE+COD))
3545       PPT = SQRT(P1CMS(1)**2+P1CMS(2)**2)
3546       SID = PPT/P1TOT
3547       COF = ONE
3548       SIF = ZERO
3549       IF (P1TOT*SID.GT.TINY10) THEN
3550          COF   = P1CMS(1)/(SID*P1TOT)
3551          SIF   = P1CMS(2)/(SID*P1TOT)
3552          ANORF = SQRT(COF*COF+SIF*SIF)
3553          COF   = COF/ANORF
3554          SIF   = SIF/ANORF
3555       ENDIF
3556 **check
3557 C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3558 C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3559 C     WRITE(LOUT,'(5E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),P1TOT
3560 C     WRITE(LOUT,'(5E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),P2TOT
3561 C     PAX = ZERO
3562 C     PAY = ZERO
3563 C     PAZ = P1TOT
3564 C     PAE = SQRT(AAM(IJPROJ)**2+PAZ**2)
3565 C     PBX = ZERO
3566 C     PBY = ZERO
3567 C     PBZ = -P2TOT
3568 C     PBE = SQRT(AAM(IJTARG)**2+PBZ**2)
3569 C     WRITE(LOUT,'(4E15.4)') PAX,PAY,PAZ,PAE
3570 C     WRITE(LOUT,'(4E15.4)') PBX,PBY,PBZ,PBE
3571 C     CALL DT_MYTRAN(1,PAX,PAY,PAZ,COD,SID,COF,SIF,
3572 C    &            P1CMS(1),P1CMS(2),P1CMS(3))
3573 C     CALL DT_MYTRAN(1,PBX,PBY,PBZ,COD,SID,COF,SIF,
3574 C    &            P2CMS(1),P2CMS(2),P2CMS(3))
3575 C     WRITE(LOUT,'(4E15.4)') P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4)
3576 C     WRITE(LOUT,'(4E15.4)') P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4)
3577 C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P1CMS(1),P1CMS(2),P1CMS(3),P1CMS(4),
3578 C    &            P1TOT,P1(1),P1(2),P1(3),P1(4))
3579 C     CALL DT_DALTRA(BGE,BGX,BGY,BGZ,P2CMS(1),P2CMS(2),P2CMS(3),P2CMS(4),
3580 C    &            P2TOT,P2(1),P2(2),P2(3),P2(4))
3581 C     WRITE(LOUT,'(4E15.4)') P1(1),P1(2),P1(3),P1(4)
3582 C     WRITE(LOUT,'(4E15.4)') P2(1),P2(2),P2(3),P2(4)
3583 C     STOP
3584 **
3585
3586       LBEAM = .TRUE.
3587
3588       RETURN
3589
3590     2 CONTINUE
3591
3592       IF (LBEAM) THEN
3593          IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3594          DO 20 I=NPOINT(4),NHKK
3595             IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3596      &                                   (ISTHKK(I).EQ.1001)) THEN
3597                CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3598      &                     COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3599                PECMS = PHKK(4,I)
3600                CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3601      &                     PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3602             ENDIF
3603    20    CONTINUE
3604       ELSE
3605          MODE = -1
3606       ENDIF
3607
3608       RETURN
3609       END
3610
3611 *$ CREATE DT_REJUCO.FOR
3612 *COPY DT_REJUCO
3613 *
3614 *===rejuco=============================================================*
3615 *
3616       SUBROUTINE DT_REJUCO(MODE,IREJ)
3617
3618 ************************************************************************
3619 * REJection of Unphysical COnfigurations                               *
3620 *     MODE = 1  rejection of particles with unphysically large energy  *
3621 *                                                                      *
3622 * This version dated 27.12.2006 is written by S. Roesler.              *
3623 ************************************************************************
3624
3625       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3626       SAVE
3627
3628       PARAMETER ( LINP = 10 ,
3629      &            LOUT = 6 ,
3630      &            LDAT = 9 )
3631
3632       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3633       PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3634
3635 * maximum x_cms of final state particle
3636       PARAMETER (XCMSMX = 1.4D0)
3637
3638 * event history
3639
3640       PARAMETER (NMXHKK=200000)
3641
3642       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3643      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3644      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3645
3646 * extended event history
3647       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3648      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3649      &                IHIST(2,NMXHKK)
3650
3651 * Lorentz-parameters of the current interaction
3652       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3653      &                UMO,PPCM,EPROJ,PPROJ
3654
3655       IREJ = 0
3656
3657       IF (MODE.EQ.1) THEN
3658          IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3659          ECMHLF = UMO/2.0D0
3660          DO 10 I=NPOINT(4),NHKK
3661             IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3662                XCMS = ABS(PHKK(4,I))/ECMHLF
3663                IF (XCMS.GT.XCMSMX) GOTO 9999
3664             ENDIF
3665    10    CONTINUE
3666       ENDIF
3667
3668       RETURN
3669  9999 CONTINUE
3670       IREJ = 1
3671       RETURN
3672       END
3673 *$ CREATE DT_EVENTB.FOR
3674 *COPY DT_EVENTB
3675 *
3676 *===eventb=============================================================*
3677 *
3678       SUBROUTINE DT_EVENTB(NCSY,IREJ)
3679
3680 ************************************************************************
3681 * Treatment of nucleon-nucleon interactions with full two-component    *
3682 * Dual Parton Model.                                                   *
3683 *          NCSY     number of nucleon-nucleon interactions             *
3684 *          IREJ     rejection flag                                     *
3685 * This version dated 14.01.2000 is written by S. Roesler               *
3686 ************************************************************************
3687
3688       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3689       SAVE
3690
3691       PARAMETER ( LINP = 10 ,
3692      &            LOUT = 6 ,
3693      &            LDAT = 9 )
3694
3695       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3696
3697 * event history
3698
3699       PARAMETER (NMXHKK=200000)
3700
3701       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3702      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3703      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3704
3705 * extended event history
3706       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3707      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3708      &                IHIST(2,NMXHKK)
3709 *! uncomment this line for internal phojet-fragmentation
3710 C #include "dtu_dtevtp.inc"
3711
3712 * particle properties (BAMJET index convention)
3713       CHARACTER*8  ANAME
3714       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3715      &                IICH(210),IIBAR(210),K1(210),K2(210)
3716
3717 * flags for input different options
3718       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3719       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3720      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3721
3722 * rejection counter
3723       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3724      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3725      &                IREXCI(3),IRDIFF(2),IRINC
3726
3727 * properties of interacting particles
3728       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3729
3730 * properties of photon/lepton projectiles
3731       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3732
3733 * various options for treatment of partons (DTUNUC 1.x)
3734 * (chain recombination, Cronin,..)
3735       LOGICAL LCO2CR,LINTPT
3736       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3737      &                LCO2CR,LINTPT
3738
3739 * statistics
3740       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3741      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3742      &                ICEVTG(8,0:30)
3743
3744 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3745       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3746
3747 * Glauber formalism: collision properties
3748       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3749      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
3750
3751 * flags for diffractive interactions (DTUNUC 1.x)
3752       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3753
3754 * statistics: double-Pomeron exchange
3755       COMMON /DTFLG2/ INTFLG,IPOPO
3756
3757 * flags for particle decays
3758       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3759      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3760      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3761
3762 * nucleon-nucleon event-generator
3763       CHARACTER*8 CMODEL
3764       LOGICAL LPHOIN
3765       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3766
3767 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
3768       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3769       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3770       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3771      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3772
3773 C  model switches and parameters
3774       CHARACTER*8 MDLNA
3775       INTEGER ISWMDL,IPAMDL
3776       DOUBLE PRECISION PARMDL
3777       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3778
3779 C  initial state parton radiation (internal part)
3780       INTEGER MXISR3,MXISR4
3781       PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3782       INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3783       DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3784       COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3785      &                ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3786      &                IFL1(2,MXISR3),IFL2(2,MXISR3),
3787      &                IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3788
3789 C  event debugging information
3790       INTEGER NMAXD
3791       PARAMETER (NMAXD=100)
3792       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3793      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3794       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3795      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3796
3797 C  general process information
3798       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3799       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3800
3801       DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3802      &          PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3803      &          PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3804      &          KPRON(15),ISINGL(2000)
3805
3806 * initial values for max. number of phojet scatterings and dtunuc chains
3807 * to be fragmented with one pyexec call
3808       DATA MXPHFR,MXDTFR /10,100/
3809
3810       IREJ      = 0
3811 * pointer to first parton of the first chain in dtevt common
3812       NPOINT(3) = NHKK+1
3813 * special flag for double-Pomeron statistics
3814       IPOPO = 1
3815 * counter for low-mass (DTUNUC) interactions
3816       NDTUSC = 0
3817 * counter for interactions treated by PHOJET
3818       NPHOSC = 0
3819
3820 * scan interactions for single nucleon-nucleon interactions
3821 * (this has to be checked here because Cronin modifies parton momenta)
3822       NC = NPOINT(2)
3823       IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3824       DO 8 I=1,NCSY
3825          ISINGL(I) = 0
3826          MOP = JMOHKK(1,NC)
3827          MOT = JMOHKK(1,NC+1)
3828          DIFF1 = ABS(PHKK(4,MOP)-PHKK(4,  NC)-PHKK(4,NC+2))
3829          DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3830          IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3831          NC = NC+4
3832     8 CONTINUE
3833
3834 * multiple scattering of chain ends
3835       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3836       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3837
3838 * switch to PHOJET-settings for JETSET parameter
3839       CALL DT_INITJS(1)
3840
3841 * loop over nucleon-nucleon interaction
3842       NC = NPOINT(2)
3843       DO 2 I=1,NCSY
3844 *
3845 *   pick up one nucleon-nucleon interaction from DTEVT1
3846 *     ppnn  / ptnn   - momenta of the interacting nucleons (cms)
3847 *     ptotnn         - total momentum of the interacting nucleons (cms)
3848 *     pp1,2 / pt1,2  - momenta of the four partons
3849 *     pp    / pt     - total momenta of the proj / targ partons
3850 *     ptot           - total momentum of the four partons
3851          MOP = JMOHKK(1,NC)
3852          MOT = JMOHKK(1,NC+1)
3853          DO 3 K=1,4
3854             PPNN(K)   = PHKK(K,MOP)
3855             PTNN(K)   = PHKK(K,MOT)
3856             PTOTNN(K) = PPNN(K)+PTNN(K)
3857             PP1(K)    = PHKK(K,NC)
3858             PT1(K)    = PHKK(K,NC+1)
3859             PP2(K)    = PHKK(K,NC+2)
3860             PT2(K)    = PHKK(K,NC+3)
3861             PP(K)     = PP1(K)+PP2(K)
3862             PT(K)     = PT1(K)+PT2(K)
3863             PTOT(K)   = PP(K)+PT(K)
3864     3    CONTINUE
3865 *
3866 *-----------------------------------------------------------------------
3867 *   this is a complete nucleon-nucleon interaction
3868 *
3869          IF (ISINGL(I).EQ.1) THEN
3870 *
3871 *     initialize PHOJET-variables for remnant/valence-partons
3872             IHFLD(1,1) = 0
3873             IHFLD(1,2) = 0
3874             IHFLD(2,1) = 0
3875             IHFLD(2,2) = 0
3876             IHFLS(1) = 1
3877             IHFLS(2) = 1
3878 *     save current settings of PHOJET process and min. bias flags
3879             DO 9 K=1,11
3880                KPRON(K) = IPRON(K,1)
3881     9       CONTINUE
3882             ISWSAV   = ISWMDL(2)
3883 *
3884 *     check if forced sampling of diffractive interaction requested
3885             IF (ISINGD.LT.-1) THEN
3886                DO 90 K=1,11
3887                   IPRON(K,1) = 0
3888    90          CONTINUE
3889                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3890                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3891                IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3892             ENDIF
3893 *
3894 *     for photons: a direct/anomalous interaction is not sampled
3895 *     in PHOJET but already in Glauber-formalism. Here we check if such
3896 *     an interaction is requested
3897             IF (IJPROJ.EQ.7) THEN
3898 *       first switch off direct interactions
3899                IPRON(8,1) = 0
3900 *       this is a direct interactions
3901                IF (IDIREC.EQ.1) THEN
3902                   DO 12 K=1,11
3903                      IPRON(K,1) = 0
3904    12             CONTINUE
3905                   IPRON(8,1) = 1
3906 *       this is an anomalous interactions
3907 *         (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3908                ELSEIF (IDIREC.EQ.2) THEN
3909                   ISWMDL(2) = 0
3910                ENDIF
3911             ELSE
3912                IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3913             ENDIF
3914 *
3915 *     make sure that total momenta of partons, pp and pt, are on mass
3916 *     shell (Cronin may have srewed this up..)
3917             CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3918             IF (IR1.NE.0) THEN
3919                IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3920      &              'EVENTB:  mass shell correction rejected'
3921                GOTO 9999
3922             ENDIF
3923 *
3924 *     initialize the incoming particles in PHOJET
3925             IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3926
3927                CALL PHO_SETPAR(1,22,0,VIRT)
3928
3929             ELSE
3930
3931                CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3932
3933             ENDIF
3934
3935             CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3936
3937 *
3938 *     initialize rejection loop counter for anomalous processes
3939             IRJANO = 0
3940   800       CONTINUE
3941             IRJANO = IRJANO+1
3942 *
3943 *     temporary fix for ifano problem
3944             IFANO(1) = 0
3945             IFANO(2) = 0
3946 *
3947 *     generate complete hadron/nucleon/photon-nucleon event with PHOJET
3948
3949             CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3950
3951 *
3952 *     for photons: special consistency check for anomalous interactions
3953             IF (IJPROJ.EQ.7) THEN
3954                IF (IRJANO.LT.30) THEN
3955                   IF (IFANO(1).NE.0) THEN
3956 *       here, an anomalous interaction was generated. Check if it
3957 *       was also requested. Otherwise reject this event.
3958                      IF (IDIREC.EQ.0) GOTO 800
3959                   ELSE
3960 *       here, an anomalous interaction was not generated. Check if it
3961 *       was requested in which case we need to reject this event.
3962                      IF (IDIREC.EQ.2) GOTO 800
3963                   ENDIF
3964                ELSE
3965                   WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3966      &                          IRJANO,IDIREC,NEVHKK
3967                ENDIF
3968             ENDIF
3969 *
3970 *     copy back original settings of PHOJET process and min. bias flags
3971             DO 10 K=1,11
3972                IPRON(K,1) = KPRON(K)
3973    10       CONTINUE
3974             ISWMDL(2) = ISWSAV
3975 *
3976 *     check if PHOJET has rejected this event
3977             IF (IREJ1.NE.0) THEN
3978 C              IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3979                WRITE(LOUT,'(1X,A,I4)')
3980      &            'EVENTB:  chain system rejected',IDIREC
3981
3982                CALL PHO_PREVNT(0)
3983
3984                GOTO 9999
3985             ENDIF
3986 *
3987 *     copy partons and strings from PHOJET common back into DTEVT for
3988 *     external fragmentation
3989             MO1 = NC
3990             MO2 = NC+3
3991 *!      uncomment this line for internal phojet-fragmentation
3992 C           CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3993             NPHOSC = NPHOSC+1
3994             CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3995             IF (IREJ1.NE.0) THEN
3996                IF (IOULEV(1).GT.0)
3997      &         WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3998                GOTO 9999
3999             ENDIF
4000 *
4001 *     update statistics counter
4002             ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
4003 *
4004 *-----------------------------------------------------------------------
4005 *   this interaction involves "remnants"
4006 *
4007          ELSE
4008 *
4009 *     total mass of this system
4010             PPTOT  = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
4011             AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
4012             IF (AMTOT2.LT.ZERO) THEN
4013                AMTOT = ZERO
4014             ELSE
4015                AMTOT = SQRT(AMTOT2)
4016             ENDIF
4017 *
4018 *     systems with masses larger than elojet are treated with PHOJET
4019             IF (AMTOT.GT.ELOJET) THEN
4020 *
4021 *     initialize PHOJET-variables for remnant/valence-partons
4022 *       projectile parton flavors and valence flag
4023                IHFLD(1,1) = IDHKK(NC)
4024                IHFLD(1,2) = IDHKK(NC+2)
4025                IHFLS(1)   = 0
4026                IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
4027      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
4028 *       target parton flavors and valence flag
4029                IHFLD(2,1) = IDHKK(NC+1)
4030                IHFLD(2,2) = IDHKK(NC+3)
4031                IHFLS(2)   = 0
4032                IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
4033      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
4034 *       flag signalizing PHOJET how to treat the remnant:
4035 *         iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
4036 *         iremn > -1 valence remnant: PHOJET assumes flavors according
4037 *                    to mother particle
4038                IREMN1 = IHFLS(1)-1
4039                IREMN2 = IHFLS(2)-1
4040 *
4041 *     initialize the incoming particles in PHOJET
4042                IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
4043
4044                   CALL PHO_SETPAR(1,22,IREMN1,VIRT)
4045
4046                ELSE
4047
4048                   CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
4049
4050                ENDIF
4051
4052                CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
4053
4054 *
4055 *     calculate Lorentz parameter of the nucleon-nucleon cm-system
4056                PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
4057                AMNN   = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
4058                BGX    = PTOTNN(1)/AMNN
4059                BGY    = PTOTNN(2)/AMNN
4060                BGZ    = PTOTNN(3)/AMNN
4061                GAM    = PTOTNN(4)/AMNN
4062 *     transform interacting nucleons into nucleon-nucleon cm-system
4063                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4064      &                     PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
4065      &                     PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
4066                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4067      &                     PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
4068      &                     PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
4069 *     transform (total) momenta of the proj and targ partons into
4070 *     nucleon-nucleon cm-system
4071                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4072      &                     PP(1),PP(2),PP(3),PP(4),
4073      &                     PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
4074                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4075      &                     PT(1),PT(2),PT(3),PT(4),
4076      &                     PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
4077 *     energy fractions of the proj and targ partons
4078                XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
4079                XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
4080 ***
4081 * testprint
4082 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
4083 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
4084 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
4085 c              EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
4086 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
4087 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
4088 c    &                        (PPSUB(2)+PTSUB(2))**2 +
4089 c    &                        (PPSUB(3)+PTSUB(3))**2 )
4090 c              EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
4091 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
4092 ***
4093 *
4094 *     save current settings of PHOJET process and min. bias flags
4095                DO 7 K=1,11
4096                   KPRON(K) = IPRON(K,1)
4097     7          CONTINUE
4098 *     disallow direct photon int. (does not make sense here anyway)
4099                IPRON(8,1) = 0
4100 *     disallow double pomeron processes (due to technical problems
4101 *     in PHOJET, needs to be solved sometime)
4102                IPRON(4,1) = 0
4103 *     disallow diffraction for sea-diquarks
4104                IF ((IABS(IHFLD(1,1)).GT.1100).AND.
4105      &             (IABS(IHFLD(1,2)).GT.1100)) THEN
4106                   IPRON(3,1) = 0
4107                   IPRON(6,1) = 0
4108                ENDIF
4109                IF ((IABS(IHFLD(2,1)).GT.1100).AND.
4110      &             (IABS(IHFLD(2,2)).GT.1100)) THEN
4111                   IPRON(3,1) = 0
4112                   IPRON(5,1) = 0
4113                ENDIF
4114 *
4115 *     we need massless partons: transform them on mass shell
4116                XMP = ZERO
4117                XMT = ZERO
4118                DO 6 K=1,4
4119                   PPTMP(K) = PPSUB(K)
4120                   PTTMP(K) = PTSUB(K)
4121     6          CONTINUE
4122                CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
4123                PPSUTO  = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
4124                PTSUTO  = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
4125                PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
4126      &                  (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
4127 *     total energy of the subsysten after mass transformation
4128 *      (should be the same as before..)
4129                SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
4130      &                      (PPSUB(4)+PTSUB(4)+PSUTOT) )
4131 *
4132 *     after mass shell transformation the x_sub - relation has to be
4133 *     corrected. We therefore create "pseudo-momenta" of mother-nucleons.
4134 *
4135 *     The old version was to scale based on the original x_sub and the
4136 *     4-momenta of the subsystem. At very high energy this could lead to
4137 *     "pseudo-cm energies" of the parent system considerably exceeding
4138 *     the true cm energy. Now we keep the true cm energy and calculate
4139 *     new x_sub instead.
4140 C old version  PPTCMS(4) = PPSUB(4)/XPSUB
4141                PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
4142                XPSUB = PPSUB(4)/PPTCMS(4)
4143                IF (IJPROJ.EQ.7) THEN
4144                   AMP2  = PHKK(5,MOT)**2
4145                   PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
4146                ELSE
4147 *???????
4148                   PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
4149      &                        *(PPTCMS(4)+PHKK(5,MOP)))
4150 C                 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
4151 C    &                        *(PPTCMS(4)+PHKK(5,MOT)))
4152                ENDIF
4153 C old version  PTTCMS(4) = PTSUB(4)/XTSUB
4154                PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
4155                XTSUB = PTSUB(4)/PTTCMS(4)
4156                PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
4157      &                     *(PTTCMS(4)+PHKK(5,MOT)))
4158                DO 4 K=1,3
4159                   PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
4160                   PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
4161     4          CONTINUE
4162 ***
4163 * testprint
4164 *
4165 *     ppnn  / ptnn   - momenta of the int. nucleons (cms, negl. Fermi)
4166 *     ptotnn         - total momentum of the int. nucleons (cms, negl. Fermi)
4167 *     pptcms/ pttcms - momenta of the interacting nucleons (cms)
4168 *     pp1,2 / pt1,2  - momenta of the four partons
4169 *
4170 *     pp    / pt     - total momenta of the pr/ta partons (cms, negl. Fermi)
4171 *     ptot           - total momentum of the four partons (cms, negl. Fermi)
4172 *     ppsub / ptsub  - total momenta of the proj / targ partons (cms)
4173 *
4174 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
4175 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
4176 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
4177 c              ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
4178 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
4179 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
4180 c    &                        (PPSUB(2)+PTSUB(2))**2 +
4181 c    &                        (PPSUB(3)+PTSUB(3))**2 )
4182 c              ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
4183 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
4184 c              IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
4185 c                 WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
4186 c                 WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
4187 c                 WRITE(*,*) ' XPSUB,  XTSUB  : ',XPSUB,XTSUB
4188 c              ENDIF
4189 c              BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
4190 c              BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
4191 c              BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
4192 c              BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
4193 *     transform interacting nucleons into nucleon-nucleon cm-system
4194 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4195 c    &                    PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
4196 c    &                     PPNEW1,PPNEW2,PPNEW3,PPNEW4)
4197 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4198 c    &                    PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
4199 c    &                     PTNEW1,PTNEW2,PTNEW3,PTNEW4)
4200 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4201 c    &                     PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
4202 c    &                     PPSUB1,PPSUB2,PPSUB3,PPSUB4)
4203 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4204 c    &                     PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
4205 c    &                     PTSUB1,PTSUB2,PTSUB3,PTSUB4)
4206 c              PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
4207 c    &                        (PPNEW2+PTNEW2)**2 +
4208 c    &                        (PPNEW3+PTNEW3)**2 )
4209 c              ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
4210 c    &                        (PPNEW4+PTNEW4+PTSTCM) )
4211 c              PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
4212 c    &                        (PPSUB2+PTSUB2)**2 +
4213 c    &                        (PPSUB3+PTSUB3)**2 )
4214 c              ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
4215 c    &                        (PPSUB4+PTSUB4+PTSTSU) )
4216 C              WRITE(*,*) ' mother cmE :'
4217 C              WRITE(*,*) ETSTCM,ENEWCM
4218 C              WRITE(*,*) ' subsystem cmE :'
4219 C              WRITE(*,*) ETSTSU,ENEWSU
4220 C              WRITE(*,*) ' projectile mother :'
4221 C              WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
4222 C              WRITE(*,*) ' target mother :'
4223 C              WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
4224 C              WRITE(*,*) ' projectile subsystem:'
4225 C              WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
4226 C              WRITE(*,*) ' target subsystem:'
4227 C              WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
4228 C              WRITE(*,*) ' projectile subsystem should be:'
4229 C              WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
4230 C    &                    XPSUB*ETSTCM/2.0D0
4231 C              WRITE(*,*) ' target subsystem should be:'
4232 C              WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
4233 C    &                    XTSUB*ETSTCM/2.0D0
4234 C              WRITE(*,*) ' subsystem cmE should be: '
4235 C              WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
4236 ***
4237 *
4238 *     generate complete remnant - nucleon/remnant event with PHOJET
4239
4240                CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
4241
4242 *
4243 *     copy back original settings of PHOJET process flags
4244                DO 11 K=1,11
4245                   IPRON(K,1) = KPRON(K)
4246    11          CONTINUE
4247 *
4248 *     check if PHOJET has rejected this event
4249                IF (IREJ1.NE.0) THEN
4250                   IF (IOULEV(1).GT.0)
4251      &            WRITE(LOUT,'(1X,A)') 'EVENTB:  chain system rejected'
4252                   WRITE(LOUT,*)
4253      &                 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
4254
4255                   CALL PHO_PREVNT(0)
4256
4257                   GOTO 9999
4258                ENDIF
4259 *
4260 *     copy partons and strings from PHOJET common back into DTEVT for
4261 *     external fragmentation
4262                MO1 = NC
4263                MO2 = NC+3
4264 *!      uncomment this line for internal phojet-fragmentation
4265 C              CALL DT_GETFSP(MO1,MO2,PP,PT,1)
4266                NPHOSC = NPHOSC+1
4267                CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
4268                IF (IREJ1.NE.0) THEN
4269                   IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
4270      &               'EVENTB: chain system rejected 2'
4271                   GOTO 9999
4272                ENDIF
4273 *
4274 *     update statistics counter
4275                ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
4276 *
4277 *-----------------------------------------------------------------------
4278 * two-chain approx. for smaller systems
4279 *
4280             ELSE
4281 *
4282                NDTUSC = NDTUSC+1
4283 *   special flag for double-Pomeron statistics
4284                IPOPO = 0
4285 *
4286 *   pick up flavors at the ends of the two chains
4287                IFP1 = IDHKK(NC)
4288                IFT1 = IDHKK(NC+1)
4289                IFP2 = IDHKK(NC+2)
4290                IFT2 = IDHKK(NC+3)
4291 *   ..and the indices of the mothers
4292                MOP1 = NC
4293                MOT1 = NC+1
4294                MOP2 = NC+2
4295                MOT2 = NC+3
4296                CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4297      &                     IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4298 *
4299 *   check if this chain system was rejected
4300                IF (IREJ1.GT.0) THEN
4301                   IF (IOULEV(1).GT.0) THEN
4302                      WRITE(LOUT,*) 'rejected 1 in EVENTB'
4303                      WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4304      &                  IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4305                   ENDIF
4306                   IRHHA = IRHHA+1
4307                   GOTO 9999
4308                ENDIF
4309 *   the following lines are for sea-sea chains rejected in GETCSY
4310                IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4311                ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4312             ENDIF
4313 *
4314          ENDIF
4315 *
4316 *     update statistics counter
4317          ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4318 *
4319          NC = NC+4
4320 *
4321     2 CONTINUE
4322 *
4323 *-----------------------------------------------------------------------
4324 * treatment of low-mass chains (if there are any)
4325 *
4326       IF (NDTUSC.GT.0) THEN
4327 *
4328 *   correct chains of very low masses for possible resonances
4329          IF (IRESCO.EQ.1) THEN
4330             CALL DT_EVTRES(IREJ1)
4331             IF (IREJ1.GT.0) THEN
4332                IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4333                IRRES(1) = IRRES(1)+1
4334                GOTO 9999
4335             ENDIF
4336          ENDIF
4337 *   fragmentation of low-mass chains
4338 *!  uncomment this line for internal phojet-fragmentation
4339 *   (of course it will still be fragmented by DPMJET-routines but it
4340 *    has to be done here instead of further below)
4341 C        CALL DT_EVTFRA(IREJ1)
4342 C        IF (IREJ1.GT.0) THEN
4343 C           IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4344 C           IRFRAG = IRFRAG+1
4345 C           GOTO 9999
4346 C        ENDIF
4347       ELSE
4348 *! uncomment this line for internal phojet-fragmentation
4349 C        NPOINT(4) = NHKK+1
4350          IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4351       ENDIF
4352 *
4353 *-----------------------------------------------------------------------
4354 * new di-quark breaking mechanisms
4355 *
4356       MXLEFT = 2
4357       CALL DT_CHASTA(0)
4358       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4359      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
4360          CALL DT_DIQBRK
4361          MXLEFT = 4
4362       ENDIF
4363 *
4364 *-----------------------------------------------------------------------
4365 * hadronize this event
4366 *
4367 *   hadronize PHOJET chain systems
4368       NPYMAX = 0
4369       NPJE   = NPHOSC/MXPHFR
4370       IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4371       IF (NPJE.GT.1) THEN
4372          NLEFT = NPHOSC-NPJE*MXPHFR
4373          DO 20 JFRG=1,NPJE
4374             NFRG = JFRG*MXPHFR
4375             IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4376                CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4377                IF (IREJ1.GT.0) GOTO 22
4378                NLEFT = 0
4379             ELSE
4380                CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4381                IF (IREJ1.GT.0) GOTO 22
4382             ENDIF
4383             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4384    20    CONTINUE
4385          IF (NLEFT.GT.0) THEN
4386             CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4387             IF (IREJ1.GT.0) GOTO 22
4388             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4389          ENDIF
4390       ELSE
4391          CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4392          IF (IREJ1.GT.0) GOTO 22
4393          IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4394       ENDIF
4395 *
4396 *   check max. filling level of jetset common and
4397 *   reduce mxphfr if necessary
4398       IF (NPYMAX.GT.3000) THEN
4399          IF (NPYMAX.GT.3500) THEN
4400             MXPHFR = MAX(1,MXPHFR-2)
4401          ELSE
4402             MXPHFR = MAX(1,MXPHFR-1)
4403          ENDIF
4404 C        WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4405       ENDIF
4406 *
4407 *   hadronize DTUNUC chain systems
4408    23 CONTINUE
4409       IBACK = MXDTFR
4410       CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4411       IF (IREJ2.GT.0) GOTO 22
4412 *
4413 *   check max. filling level of jetset common and
4414 *   reduce mxdtfr if necessary
4415       IF (NPYMEM.GT.3000) THEN
4416          IF (NPYMEM.GT.3500) THEN
4417             MXDTFR = MAX(1,MXDTFR-20)
4418          ELSE
4419             MXDTFR = MAX(1,MXDTFR-10)
4420          ENDIF
4421 C        WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4422       ENDIF
4423 *
4424       IF (IBACK.EQ.-1) GOTO 23
4425 *
4426    22 CONTINUE
4427 C     CALL DT_EVTFRG(1,IREJ1)
4428 C     CALL DT_EVTFRG(2,IREJ2)
4429       IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4430          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4431          IRFRAG = IRFRAG+1
4432          GOTO 9999
4433       ENDIF
4434 *
4435 * get final state particles from /DTEVTP/
4436 *! uncomment this line for internal phojet-fragmentation
4437 C     CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4438
4439       IF (IJPROJ.NE.7)
4440      &   CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4441 C     IF (IREJ3.NE.0) GOTO 9999
4442
4443       RETURN
4444
4445  9999 CONTINUE
4446       IREVT = IREVT+1
4447       IREJ  = 1
4448       RETURN
4449       END
4450
4451 *$ CREATE DT_GETPJE.FOR
4452 *COPY DT_GETPJE
4453 *
4454 *===getpje=============================================================*
4455 *
4456       SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4457
4458 ************************************************************************
4459 * This subroutine copies PHOJET partons and strings from POEVT1 into   *
4460 * DTEVT1.                                                              *
4461 *      MO1,MO2   indices of first and last mother-parton in DTEVT1     *
4462 *      PP,PT     4-momenta of projectile/target being handled by       *
4463 *                PHOJET                                                *
4464 * This version dated 11.12.99 is written by S. Roesler                 *
4465 ************************************************************************
4466
4467       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4468       SAVE
4469
4470       PARAMETER ( LINP = 10 ,
4471      &            LOUT = 6 ,
4472      &            LDAT = 9 )
4473
4474       PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4475      &           ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4476
4477       LOGICAL LFLIP
4478
4479 * event history
4480
4481       PARAMETER (NMXHKK=200000)
4482
4483       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4484      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4485      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4486
4487 * extended event history
4488       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4489      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4490      &                IHIST(2,NMXHKK)
4491
4492 * Lorentz-parameters of the current interaction
4493       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4494      &                UMO,PPCM,EPROJ,PPROJ
4495
4496 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4497       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4498
4499 * flags for input different options
4500       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4501       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4502      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4503
4504 * statistics: double-Pomeron exchange
4505       COMMON /DTFLG2/ INTFLG,IPOPO
4506
4507 * statistics
4508       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4509      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4510      &                ICEVTG(8,0:30)
4511
4512 * rejection counter
4513       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4514      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4515      &                IREXCI(3),IRDIFF(2),IRINC
4516 C  standard particle data interface
4517       INTEGER NMXHEP
4518
4519       PARAMETER (NMXHEP=4000)
4520
4521       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4522       DOUBLE PRECISION PHEP,VHEP
4523       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4524      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4525      &                VHEP(4,NMXHEP)
4526 C  extension to standard particle data interface (PHOJET specific)
4527       INTEGER IMPART,IPHIST,ICOLOR
4528       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4529
4530 C  color string configurations including collapsed strings and hadrons
4531       INTEGER MSTR
4532       PARAMETER (MSTR=500)
4533       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4534       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4535      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4536      &                NNCH(MSTR),IBHAD(MSTR),ISTR
4537
4538 C  general process information
4539       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4540       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4541
4542 C  model switches and parameters
4543       CHARACTER*8 MDLNA
4544       INTEGER ISWMDL,IPAMDL
4545       DOUBLE PRECISION PARMDL
4546       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4547
4548 C  event debugging information
4549       INTEGER NMAXD
4550       PARAMETER (NMAXD=100)
4551       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4552      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4553       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4554      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4555
4556       DIMENSION PP(4),PT(4)
4557       DATA MAXLOP /10000/
4558
4559       INHKK = NHKK
4560       LFLIP = .TRUE.
4561     1 CONTINUE
4562       NPVAL = 0
4563       NTVAL = 0
4564       IREJ  = 0
4565
4566 *   store initial momenta for energy-momentum conservation check
4567       IF (LEMCCK) THEN
4568          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4569          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4570       ENDIF
4571 * copy partons and strings from POEVT1 into DTEVT1
4572       DO 11 I=1,ISTR
4573 C        IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4574          IF (NCODE(I).EQ.-99) THEN
4575             IDXSTG = NPOS(1,I)
4576             IDSTG  = IDHEP(IDXSTG)
4577             PX = PHEP(1,IDXSTG)
4578             PY = PHEP(2,IDXSTG)
4579             PZ = PHEP(3,IDXSTG)
4580             PE = PHEP(4,IDXSTG)
4581             IF (MODE.LT.0) THEN
4582                ISTAT = 70000+IPJE
4583                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4584      &                        11,IDSTG,0)
4585                IF (LEMCCK) THEN
4586                   PX = -PX
4587                   PY = -PY
4588                   PZ = -PZ
4589                   PE = -PE
4590                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4591                ENDIF
4592             ELSE
4593                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4594      &                        PPX,PPY,PPZ,PPE)
4595                ISTAT = 70000+IPJE
4596                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4597      &                        11,IDSTG,0)
4598                IF (LEMCCK) THEN
4599                   PX = -PPX
4600                   PY = -PPY
4601                   PZ = -PPZ
4602                   PE = -PPE
4603                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4604                ENDIF
4605             ENDIF
4606             NOBAM(NHKK)   = 0
4607             IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4608             IHIST(2,NHKK) = 0
4609          ELSEIF (NCODE(I).GE.0) THEN
4610 *   indices of partons and string in POEVT1
4611             IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4612             IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4613             IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4614                WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4615      &         ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4616                STOP ' GETPJE 1'
4617             ENDIF
4618             IDXSTG = NPOS(1,I)
4619 *   find "mother" string of the string
4620             IDXMS1 = ABS(JMOHEP(1,IDX1))
4621             IDXMS2 = ABS(JMOHEP(1,IDX2))
4622             IF (IDXMS1.NE.IDXMS2) THEN
4623                IDXMS1 = IDXSTG
4624                IDXMS2 = IDXSTG
4625 C              STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4626             ENDIF
4627 *   search POEVT1 for the original hadron of the parton
4628             ILOOP = 0
4629             IPOM1 = 0
4630    14       CONTINUE
4631             ILOOP = ILOOP+1
4632
4633             IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4634
4635             IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4636             IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4637      &          (ILOOP.LT.MAXLOP)) GOTO 14
4638             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4639             IPOM2 = 0
4640             ILOOP = 0
4641    15       CONTINUE
4642             ILOOP = ILOOP+1
4643
4644             IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4645
4646             IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4647                IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4648             ELSE
4649                IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4650             ENDIF
4651             IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4652      &          (ILOOP.LT.MAXLOP)) GOTO 15
4653             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4654 *   parton 1
4655             IF (IDXMS1.EQ.1) THEN
4656                ISPTN1 = ISTHKK(MO1)
4657                M1PTN1 = MO1
4658                M2PTN1 = MO1+2
4659             ELSE
4660                ISPTN1 = ISTHKK(MO2)
4661                M1PTN1 = MO2-2
4662                M2PTN1 = MO2
4663             ENDIF
4664 *   parton 2
4665             IF (IDXMS2.EQ.1) THEN
4666                ISPTN2 = ISTHKK(MO1)
4667                M1PTN2 = MO1
4668                M2PTN2 = MO1+2
4669             ELSE
4670                ISPTN2 = ISTHKK(MO2)
4671                M1PTN2 = MO2-2
4672                M2PTN2 = MO2
4673             ENDIF
4674 *   check for mis-identified mothers and switch mother indices if necessary
4675             IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4676      &          .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4677      &          (LFLIP)) THEN
4678                IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4679                   ISPTN1 = ISTHKK(MO1)
4680                   M1PTN1 = MO1
4681                   M2PTN1 = MO1+2
4682                   ISPTN2 = ISTHKK(MO2)
4683                   M1PTN2 = MO2-2
4684                   M2PTN2 = MO2
4685                ELSE
4686                   ISPTN1 = ISTHKK(MO2)
4687                   M1PTN1 = MO2-2
4688                   M2PTN1 = MO2
4689                   ISPTN2 = ISTHKK(MO1)
4690                   M1PTN2 = MO1
4691                   M2PTN2 = MO1+2
4692                ENDIF
4693             ENDIF
4694 *   register partons in temporary common
4695 *     parton at chain end
4696             PX = PHEP(1,IDX1)
4697             PY = PHEP(2,IDX1)
4698             PZ = PHEP(3,IDX1)
4699             PE = PHEP(4,IDX1)
4700 * flag only partons coming from Pomeron with 41/42
4701 C           IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4702             IF (IPOM1.NE.0) THEN
4703                ISTX = ABS(ISPTN1)/10
4704                IMO  = ABS(ISPTN1)-10*ISTX
4705                ISPTN1 = -(40+IMO)
4706             ELSE
4707                IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4708                   ISTX = ABS(ISPTN1)/10
4709                   IMO  = ABS(ISPTN1)-10*ISTX
4710                   IF ((IDHEP(IDX1).EQ.21).OR.
4711      &                (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4712                      ISPTN1 = -(60+IMO)
4713                   ELSE
4714                      ISPTN1 = -(50+IMO)
4715                   ENDIF
4716                ENDIF
4717             ENDIF
4718             IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4719             IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4720             IF (MODE.LT.0) THEN
4721                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4722      &                        PZ,PE,0,0,0)
4723             ELSE
4724                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4725      &                        PPX,PPY,PPZ,PPE)
4726                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4727      &                        PPZ,PPE,0,0,0)
4728             ENDIF
4729             IHIST(1,NHKK) = IPHIST(1,IDX1)
4730             IHIST(2,NHKK) = 0
4731             DO 19 KK=1,4
4732                VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4733                WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4734    19       CONTINUE
4735             VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4736             WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4737             M1STRG = NHKK
4738 *     gluon kinks
4739             NGLUON = IDX2-IDX1-1
4740             IF (NGLUON.GT.0) THEN
4741                DO 17 IGLUON=1,NGLUON
4742                   IDX   = IDX1+IGLUON
4743                   IDXMS = ABS(JMOHEP(1,IDX))
4744                   IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4745                      ILOOP = 0
4746    16                CONTINUE
4747                      ILOOP = ILOOP+1
4748                      IDXMS = ABS(JMOHEP(1,IDXMS))
4749                      IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4750      &                   (ILOOP.LT.MAXLOP)) GOTO 16
4751                      IF (ILOOP.EQ.MAXLOP)
4752      &                  WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4753                   ENDIF
4754                   IF (IDXMS.EQ.1) THEN
4755                      ISPTN = ISTHKK(MO1)
4756                      M1PTN = MO1
4757                      M2PTN = MO1+2
4758                   ELSE
4759                      ISPTN = ISTHKK(MO2)
4760                      M1PTN = MO2-2
4761                      M2PTN = MO2
4762                   ENDIF
4763                   PX = PHEP(1,IDX)
4764                   PY = PHEP(2,IDX)
4765                   PZ = PHEP(3,IDX)
4766                   PE = PHEP(4,IDX)
4767                   IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4768                      ISTX = ABS(ISPTN)/10
4769                      IMO  = ABS(ISPTN)-10*ISTX
4770                      IF ((IDHEP(IDX).EQ.21).OR.
4771      &                   (ABS(IPHIST(1,IDX)).GE.100)) THEN
4772                         ISPTN = -(60+IMO)
4773                      ELSE
4774                         ISPTN = -(50+IMO)
4775                      ENDIF
4776                   ENDIF
4777                   IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4778                   IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4779                   IF (MODE.LT.0) THEN
4780                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4781      &                              PX,PY,PZ,PE,0,0,0)
4782                   ELSE
4783                      CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4784      &                              PPX,PPY,PPZ,PPE)
4785                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4786      &                              PPX,PPY,PPZ,PPE,0,0,0)
4787                   ENDIF
4788                   IHIST(1,NHKK) = IPHIST(1,IDX)
4789                   IHIST(2,NHKK) = 0
4790                   DO 20 KK=1,4
4791                      VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4792                      WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4793    20             CONTINUE
4794                   VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4795                   WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4796    17          CONTINUE
4797             ENDIF
4798 *     parton at chain end
4799             PX = PHEP(1,IDX2)
4800             PY = PHEP(2,IDX2)
4801             PZ = PHEP(3,IDX2)
4802             PE = PHEP(4,IDX2)
4803 * flag only partons coming from Pomeron with 41/42
4804 C           IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4805             IF (IPOM2.NE.0) THEN
4806                ISTX = ABS(ISPTN2)/10
4807                IMO  = ABS(ISPTN2)-10*ISTX
4808                ISPTN2 = -(40+IMO)
4809             ELSE
4810                IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4811                   ISTX = ABS(ISPTN2)/10
4812                   IMO  = ABS(ISPTN2)-10*ISTX
4813                   IF ((IDHEP(IDX2).EQ.21).OR.
4814      &                (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4815                      ISPTN2 = -(60+IMO)
4816                   ELSE
4817                      ISPTN2 = -(50+IMO)
4818                   ENDIF
4819                ENDIF
4820             ENDIF
4821             IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4822             IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4823             IF (MODE.LT.0) THEN
4824                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4825      &                        PX,PY,PZ,PE,0,0,0)
4826             ELSE
4827                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4828      &                        PPX,PPY,PPZ,PPE)
4829                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4830      &                        PPX,PPY,PPZ,PPE,0,0,0)
4831             ENDIF
4832             IHIST(1,NHKK) = IPHIST(1,IDX2)
4833             IHIST(2,NHKK) = 0
4834             DO 21 KK=1,4
4835                VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4836                WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4837    21       CONTINUE
4838             VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4839             WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4840             M2STRG = NHKK
4841 *   register string
4842             JSTRG = 100*IPROCE+NCODE(I)
4843             PX = PHEP(1,IDXSTG)
4844             PY = PHEP(2,IDXSTG)
4845             PZ = PHEP(3,IDXSTG)
4846             PE = PHEP(4,IDXSTG)
4847             IF (MODE.LT.0) THEN
4848                ISTAT = 70000+IPJE
4849                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4850      &                        PX,PY,PZ,PE,0,0,0)
4851                IF (LEMCCK) THEN
4852                   PX = -PX
4853                   PY = -PY
4854                   PZ = -PZ
4855                   PE = -PE
4856                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4857                ENDIF
4858             ELSE
4859                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4860      &                        PPX,PPY,PPZ,PPE)
4861                ISTAT = 70000+IPJE
4862                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4863      &                        PPX,PPY,PPZ,PPE,0,0,0)
4864                IF (LEMCCK) THEN
4865                   PX = -PPX
4866                   PY = -PPY
4867                   PZ = -PPZ
4868                   PE = -PPE
4869                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4870                ENDIF
4871             ENDIF
4872             NOBAM(NHKK)   = 0
4873             IHIST(1,NHKK) = 0
4874             IHIST(2,NHKK) = 0
4875             DO 18 KK=1,4
4876                VHKK(KK,NHKK) = VHKK(KK,MO2)
4877                WHKK(KK,NHKK) = WHKK(KK,MO1)
4878    18       CONTINUE
4879             VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4880             WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4881          ENDIF
4882    11 CONTINUE
4883
4884       IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4885          NHKK  = INHKK
4886          LFLIP = .FALSE.
4887          GOTO 1
4888       ENDIF
4889
4890       IF (LEMCCK) THEN
4891          IF (UMO.GT.1.0D5) THEN
4892             CHKLEV = 1.0D0
4893          ELSE
4894             CHKLEV = TINY1
4895          ENDIF
4896          CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4897
4898          IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4899
4900       ENDIF
4901
4902 * internal statistics
4903 *   dble-Po statistics.
4904       IF (IPROCE.NE.4) IPOPO = 0
4905
4906       INTFLG = IPROCE
4907       IDCHSY = IDCH(MO1)
4908       IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4909          ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4910       ELSE
4911          WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4912  1000    FORMAT(1X,'GETFSP:   warning! incons. process id. (',I2,
4913      &          ') at evt(chain) ',I6,'(',I2,')')
4914       ENDIF
4915       IF (IPROCE.EQ.5) THEN
4916          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4917             ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4918          ELSE
4919 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4920  1001       FORMAT(1X,'GETFSP:   warning! incons. diffrac. id. ',
4921      &             '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4922          ENDIF
4923       ELSEIF (IPROCE.EQ.6) THEN
4924          IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4925             ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4926          ELSE
4927 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4928          ENDIF
4929       ELSEIF (IPROCE.EQ.7) THEN
4930          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4931      &       (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4932             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4933      &         ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4934             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4935      &         ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4936             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4937      &         ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4938             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4939      &         ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4940          ELSE
4941             WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4942          ENDIF
4943       ENDIF
4944       IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4945      &                                                       THEN
4946          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4947          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4948          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4949       ENDIF
4950       ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4951       ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4952       ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4953       ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4954       ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4955
4956       RETURN
4957
4958  9999 CONTINUE
4959       IREJ = 1
4960       RETURN
4961       END
4962
4963 *$ CREATE DT_PHOINI.FOR
4964 *COPY DT_PHOINI
4965 *
4966 *===phoini=============================================================*
4967 *
4968       SUBROUTINE DT_PHOINI
4969
4970 ************************************************************************
4971 * Initialization PHOJET-event generator for nucleon-nucleon interact.  *
4972 * This version dated 16.11.95 is written by S. Roesler                 *
4973 *                                                                      *
4974 * Last change 27.12.2006 by S. Roesler.                                *
4975 ************************************************************************
4976
4977       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4978       SAVE
4979
4980       PARAMETER ( LINP = 10 ,
4981      &            LOUT = 6 ,
4982      &            LDAT = 9 )
4983
4984       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4985
4986 * nucleon-nucleon event-generator
4987       CHARACTER*8 CMODEL
4988       LOGICAL LPHOIN
4989       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4990
4991 * particle properties (BAMJET index convention)
4992       CHARACTER*8  ANAME
4993       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4994      &                IICH(210),IIBAR(210),K1(210),K2(210)
4995
4996 * Lorentz-parameters of the current interaction
4997       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4998      &                UMO,PPCM,EPROJ,PPROJ
4999
5000 * properties of interacting particles
5001       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5002
5003 * properties of photon/lepton projectiles
5004       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5005
5006       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
5007
5008 * emulsion treatment
5009       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
5010      &                NCOMPO,IEMUL
5011
5012 * VDM parameter for photon-nucleus interactions
5013       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
5014
5015 * nuclear potential
5016       LOGICAL LFERMI
5017       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5018      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5019      &                ETACOU(2),ICOUL,LFERMI
5020
5021 * Glauber formalism: flags and parameters for statistics
5022       LOGICAL LPROD
5023       CHARACTER*8 CGLB
5024       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
5025 *
5026 * parameters for cascade calculations:
5027 * maximum mumber of PDF's which can be defined in phojet (limited
5028 * by the dimension of ipdfs in pho_setpdf)
5029       PARAMETER (MAXPDF = 20)
5030 * PDF parametrization and number of set for the first 30 hadrons in
5031 * the bamjet-code list
5032 *   negative numbers mean that the PDF is set in phojet,
5033 *   zero stands for "not a hadron"
5034       DIMENSION IPARPD(30),ISETPD(30)
5035 * PDF parametrization
5036       DATA IPARPD /
5037      &  -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
5038      &   5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
5039 * number of set
5040       DATA ISETPD /
5041      &  -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
5042      &   6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
5043
5044 **PHOJET105a
5045 C     COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
5046 C     PARAMETER ( MAXPRO = 16 )
5047 C     PARAMETER ( MAXTAB = 20 )
5048 C     COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
5049 C    &                MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
5050 C     CHARACTER*8 MDLNA
5051 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
5052 C     COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
5053 **PHOJET110
5054
5055 C  global event kinematics and particle IDs
5056       INTEGER IFPAP,IFPAB
5057       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
5058       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
5059
5060 C  hard cross sections and MC selection weights
5061       INTEGER Max_pro_2
5062       PARAMETER ( Max_pro_2 = 16 )
5063       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
5064      &  MH_acc_1,MH_acc_2
5065       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
5066       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
5067      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
5068      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
5069      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
5070      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
5071
5072 C  model switches and parameters
5073       CHARACTER*8 MDLNA
5074       INTEGER ISWMDL,IPAMDL
5075       DOUBLE PRECISION PARMDL
5076       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
5077
5078 C  general process information
5079       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
5080       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
5081 **
5082       DIMENSION PP(4),PT(4)
5083
5084       LOGICAL LSTART
5085       DATA LSTART /.TRUE./
5086
5087       IJP = IJPROJ
5088       IJT = IJTARG
5089       Q2  = VIRT
5090 * lepton-projectiles: initialize real photon instead
5091       IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
5092          IJP = 7
5093          Q2  = ZERO
5094       ENDIF
5095
5096       IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
5097
5098 * switch Reggeon off
5099 C     IPAMDL(3)= 0
5100       IF (IP.EQ.1) THEN
5101          IFPAP(1) = IDT_IPDGHA(IJP)
5102          IFPAB(1) = IJP
5103       ELSE
5104          IFPAP(1) = 2212
5105          IFPAB(1) = IDT_ICIHAD(IFPAP(1))
5106       ENDIF
5107       PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
5108       PVIRT(1) = PMASS(1)**2
5109       IF (IT.EQ.1) THEN
5110          IFPAP(2) = IDT_IPDGHA(IJT)
5111          IFPAB(2) = IJT
5112       ELSE
5113          IFPAP(2) = 2212
5114          IFPAB(2) = IDT_ICIHAD(IFPAP(2))
5115       ENDIF
5116       PMASS(2) = AAM(IFPAB(2))
5117       PVIRT(2) = ZERO
5118       DO 1 K=1,4
5119          PP(K) = ZERO
5120          PT(K) = ZERO
5121     1 CONTINUE
5122 * get max. possible momenta of incoming particles to be used for PHOJET ini.
5123       PPF = ZERO
5124       PTF = ZERO
5125       SCPF= 1.5D0
5126       IF (UMO.GE.1.E5) THEN
5127          SCPF= 5.0D0
5128       ENDIF
5129       IF (NCOMPO.GT.0) THEN
5130          DO 2 I=1,NCOMPO
5131             IF (IT.GT.1) THEN
5132                CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
5133             ELSE
5134                CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
5135             ENDIF
5136             PPFTMP = MAX(PFERMP(1),PFERMN(1))
5137             PTFTMP = MAX(PFERMP(2),PFERMN(2))
5138             IF (PPFTMP.GT.PPF) PPF = PPFTMP
5139             IF (PTFTMP.GT.PTF) PTF = PTFTMP
5140     2    CONTINUE
5141       ELSE
5142          CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
5143          PPF = MAX(PFERMP(1),PFERMN(1))
5144          PTF = MAX(PFERMP(2),PFERMN(2))
5145       ENDIF
5146       PTF = -PTF
5147       PPF = SCPF*PPF
5148       PTF = SCPF*PTF
5149       IF (IJP.EQ.7) THEN
5150          AMP2  = SIGN(PMASS(1)**2,PMASS(1))
5151          PP(3) = PPCM
5152          PP(4) = SQRT(AMP2+PP(3)**2)
5153       ELSE
5154          EPF = SQRT(PPF**2+PMASS(1)**2)
5155          CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
5156       ENDIF
5157       ETF = SQRT(PTF**2+PMASS(2)**2)
5158       CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
5159       ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
5160      &              (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
5161       IF (LSTART) THEN
5162          WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
5163  1001    FORMAT(
5164      &      ' DT_PHOINI:    PHOJET initialized for projectile A,Z = ',
5165      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
5166          IF (NCOMPO.GT.0) THEN
5167             WRITE(LOUT,1002) SCPF,PTF,PT
5168          ELSE
5169             WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
5170          ENDIF
5171  1002    FORMAT(
5172      &      ' DT_PHOINI:    PHOJET initialized for target emulsion  ',
5173      &          /,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
5174  1003    FORMAT(
5175      &      ' DT_PHOINI:    PHOJET initialized for target     A,Z = ',
5176      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
5177          WRITE(LOUT,1004) ECMINI
5178  1004    FORMAT(' E_cm = ',E10.3)
5179          IF (IJP.EQ.8) WRITE(LOUT,1005)
5180  1005    FORMAT(
5181      &      ' DT_PHOINI: warning! proton parameters used for neutron',
5182      &          ' projectile')
5183          LSTART = .FALSE.
5184       ENDIF
5185 * switch off new diffractive cross sections at low energies for nuclei
5186 * (temporary solution)
5187       IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
5188          WRITE(LOUT,'(1X,A)')
5189      &      ' DT_PHOINI: model-switch 30 for nuclei re-set !'
5190          CALL PHO_SETMDL(30,0,1)
5191       ENDIF
5192 *
5193 C     IF (IJP.EQ.7) THEN
5194 C        AMP2  = SIGN(PMASS(1)**2,PMASS(1))
5195 C        PP(3) = PPCM
5196 C        PP(4) = SQRT(AMP2+PP(3)**2)
5197 C     ELSE
5198 C        PFERMX = ZERO
5199 C        IF (IP.GT.1) PFERMX = 0.5D0
5200 C        EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
5201 C        CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
5202 C     ENDIF
5203 C     PFERMX = ZERO
5204 C     IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
5205 C     EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
5206 C     CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
5207 **sr 26.10.96
5208       ISAV = IPAMDL(13)
5209       IF ((ISHAD(2).EQ.1).AND.
5210      &   ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
5211      &    (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
5212 **
5213
5214       CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
5215
5216 **sr 26.10.96
5217       IPAMDL(13) = ISAV
5218 **
5219 *
5220 * patch for cascade calculations:
5221 * define parton distribution functions for other hadrons, i.e. other
5222 * then defined already in phojet
5223       IF (IOGLB.EQ.100) THEN
5224          WRITE(LOUT,1006)
5225  1006    FORMAT(/,1X,'PHOINI: additional parton distribution functions',
5226      &          ' assiged (ID,IPAR,ISET)',/)
5227          NPDF = 0
5228          DO 3 I=1,30
5229             IF (IPARPD(I).NE.0) THEN
5230                NPDF = NPDF+1
5231                IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
5232                IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
5233                   IDPDG = IDT_IPDGHA(I)
5234                   IPAR  = IPARPD(I)
5235                   ISET  = ISETPD(I)
5236                   WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
5237                   CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
5238                ENDIF
5239             ENDIF
5240     3    CONTINUE
5241       ENDIF
5242
5243 C     CALL PHO_PHIST(-1,SIGMAX)
5244
5245       IF (IREJ1.NE.0) THEN
5246          WRITE(LOUT,1000)
5247  1000    FORMAT(1X,'PHOINI:   PHOJET event-initialization failed!')
5248          STOP
5249       ENDIF
5250
5251       RETURN
5252       END
5253
5254 *$ CREATE DT_EVENTD.FOR
5255 *COPY DT_EVENTD
5256 *
5257 *===eventd=============================================================*
5258 *
5259       SUBROUTINE DT_EVENTD(IREJ)
5260
5261 ************************************************************************
5262 * Quasi-elastic neutrino nucleus scattering.                           *
5263 * This version dated 29.04.00 is written by S. Roesler.                *
5264 ************************************************************************
5265
5266       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5267       SAVE
5268
5269       PARAMETER ( LINP = 10 ,
5270      &            LOUT = 6 ,
5271      &            LDAT = 9 )
5272
5273       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
5274       PARAMETER (SQTINF=1.0D+15)
5275
5276       LOGICAL LFIRST
5277
5278 * event history
5279
5280       PARAMETER (NMXHKK=200000)
5281
5282       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5283      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5284      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5285
5286 * extended event history
5287       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5288      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5289      &                IHIST(2,NMXHKK)
5290
5291 * flags for input different options
5292       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5293       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5294      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5295       PARAMETER (MAXLND=4000)
5296       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
5297
5298 * properties of interacting particles
5299       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5300
5301 * Lorentz-parameters of the current interaction
5302       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5303      &                UMO,PPCM,EPROJ,PPROJ
5304
5305 * nuclear potential
5306       LOGICAL LFERMI
5307       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5308      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5309      &                ETACOU(2),ICOUL,LFERMI
5310
5311 * steering flags for qel neutrino scattering modules
5312       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
5313
5314       COMMON /QNPOL/ POLARX(4),PMODUL
5315
5316       INTEGER PYK
5317
5318       DATA LFIRST /.TRUE./
5319
5320       IREJ = 0
5321
5322       IF (LFIRST) THEN
5323          LFIRST = .FALSE.
5324          CALL DT_MASS_INI
5325       ENDIF
5326
5327 * JETSET parameter
5328       CALL DT_INITJS(0)
5329
5330 * interacting target nucleon
5331       LTYP = NEUTYP
5332       IF (NEUDEC.LE.9) THEN
5333          IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5334             NUCTYP = 2112
5335             NUCTOP = 2
5336          ELSE
5337             NUCTYP = 2212
5338             NUCTOP = 1
5339          ENDIF
5340       ELSE
5341          RTYP  = DT_RNDM(RTYP)
5342          ZFRAC = DBLE(ITZ)/DBLE(IT)
5343          IF (RTYP.LE.ZFRAC) THEN
5344             NUCTYP = 2212
5345             NUCTOP = 1
5346          ELSE
5347             NUCTYP = 2112
5348             NUCTOP = 2
5349          ENDIF
5350       ENDIF
5351
5352 * select first nucleon in list with matching id and reset all other
5353 * nucleons which have been marked as "wounded" by ININUC
5354       IFOUND = 0
5355       DO 1 I=1,NHKK
5356          IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5357             ISTHKK(I) = 12
5358             IFOUND    = 1
5359             IDX = I
5360          ELSE
5361             IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5362          ENDIF
5363     1 CONTINUE
5364       IF (IFOUND.EQ.0)
5365      &   STOP ' EVENTD: interacting target nucleon not found! '
5366
5367 * correct position of proj. lepton: assume position of target nucleon
5368       DO 3 I=1,4
5369          VHKK(I,1) = VHKK(I,IDX)
5370          WHKK(I,1) = WHKK(I,IDX)
5371     3 CONTINUE
5372
5373 * load initial momenta for conservation check
5374       IF (LEMCCK) THEN
5375          CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5376          CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5377      &                                                      2,IDUM,IDUM)
5378       ENDIF
5379
5380 * quasi-elastic scattering
5381       IF (NEUDEC.LT.9) THEN
5382          CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5383      &                                          PHKK(4,IDX),PHKK(5,IDX))
5384 *  CC event on p or n
5385       ELSEIF (NEUDEC.EQ.10) THEN
5386          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5387      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5388 *  NC event on p or n
5389       ELSEIF (NEUDEC.EQ.11) THEN
5390          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5391      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5392       ENDIF
5393
5394 * get final state particles from Lund-common and write them into HKKEVT
5395       NPOINT(1) = NHKK+1
5396       NPOINT(4) = NHKK+1
5397
5398       NLINES = PYK(0,1)
5399
5400       NHKK0  = NHKK+1
5401       DO 4 I=4,NLINES
5402          IF (K(I,1).EQ.1) THEN
5403             ID = K(I,2)
5404             PX = P(I,1)
5405             PY = P(I,2)
5406             PZ = P(I,3)
5407             PE = P(I,4)
5408             CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5409             IDBJ = IDT_ICIHAD(ID)
5410             EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5411             IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5412                IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5413             ENDIF
5414             VHKK(1,NHKK) = VHKK(1,IDX)
5415             VHKK(2,NHKK) = VHKK(2,IDX)
5416             VHKK(3,NHKK) = VHKK(3,IDX)
5417             VHKK(4,NHKK) = VHKK(4,IDX)
5418 C           IF (I.EQ.4) THEN
5419 C              WHKK(1,NHKK) = POLARX(1)
5420 C              WHKK(2,NHKK) = POLARX(2)
5421 C              WHKK(3,NHKK) = POLARX(3)
5422 C              WHKK(4,NHKK) = POLARX(4)
5423 C           ELSE
5424                WHKK(1,NHKK) = WHKK(1,IDX)
5425                WHKK(2,NHKK) = WHKK(2,IDX)
5426                WHKK(3,NHKK) = WHKK(3,IDX)
5427                WHKK(4,NHKK) = WHKK(4,IDX)
5428 C           ENDIF
5429             IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5430          ENDIF
5431     4 CONTINUE
5432
5433       IF (LEMCCK) THEN
5434          CHKLEV = TINY5
5435          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5436          IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5437       ENDIF
5438
5439 * transform momenta into cms (as required for inc etc.)
5440       DO 5 I=NHKK0,NHKK
5441          IF (ISTHKK(I).EQ.1) THEN
5442             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5443             PHKK(3,I) = PZ
5444             PHKK(4,I) = PE
5445          ENDIF
5446     5 CONTINUE
5447
5448       RETURN
5449       END
5450 *$ CREATE DT_KKEVNT.FOR
5451 *COPY DT_KKEVNT
5452 *
5453 *===kkevnt=============================================================*
5454 *
5455       SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5456
5457 ************************************************************************
5458 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering   *
5459 * without nuclear effects (one event).                                 *
5460 * This subroutine is an update of the previous version (KKEVT) written *
5461 * by J. Ranft/ H.-J. Moehring.                                         *
5462 * This version dated 20.04.95 is written by S. Roesler                 *
5463 ************************************************************************
5464
5465       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5466       SAVE
5467
5468       PARAMETER ( LINP = 10 ,
5469      &            LOUT = 6 ,
5470      &            LDAT = 9 )
5471
5472       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5473
5474       PARAMETER ( MAXNCL = 260,
5475
5476      &            MAXVQU = MAXNCL,
5477      &            MAXSQU = 20*MAXVQU,
5478      &            MAXINT = MAXVQU+MAXSQU)
5479
5480 * event history
5481
5482       PARAMETER (NMXHKK=200000)
5483
5484       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5485      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5486      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5487
5488 * extended event history
5489       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5490      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5491      &                IHIST(2,NMXHKK)
5492
5493 * flags for input different options
5494       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5495       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5496      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5497
5498 * rejection counter
5499       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5500      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5501      &                IREXCI(3),IRDIFF(2),IRINC
5502
5503 * statistics
5504       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5505      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5506      &                ICEVTG(8,0:30)
5507
5508 * properties of interacting particles
5509       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5510
5511 * Lorentz-parameters of the current interaction
5512       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5513      &                UMO,PPCM,EPROJ,PPROJ
5514
5515 * flags for diffractive interactions (DTUNUC 1.x)
5516       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5517
5518 * interface HADRIN-DPM
5519       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5520
5521 * nucleon-nucleon event-generator
5522       CHARACTER*8 CMODEL
5523       LOGICAL LPHOIN
5524       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5525
5526 * coordinates of nucleons
5527       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5528
5529 * interface between Glauber formalism and DPM
5530       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5531      &                INTER1(MAXINT),INTER2(MAXINT)
5532
5533 * Glauber formalism: collision properties
5534       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5535      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5536
5537 * central particle production, impact parameter biasing
5538       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5539 **temporary
5540
5541 * statistics: Glauber-formalism
5542       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5543 **
5544
5545       DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5546
5547       IREJ   = 0
5548       ICREQU = ICREQU+1
5549       NC     = 0
5550
5551     1 CONTINUE
5552       ICSAMP = ICSAMP+1
5553       NC     = NC+1
5554       IF (MOD(NC,10).EQ.0) THEN
5555          WRITE(LOUT,1000) NEVHKK
5556  1000    FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5557          GOTO 9999
5558       ENDIF
5559
5560 * initialize DTEVT1/DTEVT2
5561       CALL DT_EVTINI
5562
5563 * We need the following only in order to sample nucleon coordinates.
5564 * However we don't have parameters (cross sections, slope etc.)
5565 * for neutrinos available. Therefore switch projectile to proton
5566 * in this case.
5567       IF (MCGENE.EQ.4) THEN
5568          JJPROJ = 1
5569       ELSE
5570          JJPROJ = IJPROJ
5571       ENDIF
5572
5573    10 CONTINUE
5574       IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5575 * make sure that Glauber-formalism is called each time the interaction
5576 * configuration changed
5577      &     (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5578      &     (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5579 * sample number of nucleon-nucleon coll. according to Glauber-form.
5580          CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5581          NWTSAM = NN
5582          NWASAM = NP
5583          NWBSAM = NT
5584          NEVOLD = NEVHKK
5585          IPOLD  = IP
5586          ITOLD  = IT
5587          JJPOLD = JJPROJ
5588          EPROLD = EPROJ
5589       ENDIF
5590
5591 * force diffractive particle production in h-K interactions
5592       IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5593      &    (IP.EQ.1).AND.(NN.NE.1)) THEN
5594          NEVOLD = 0
5595          GOTO 10
5596       ENDIF
5597
5598 * check number of involved proj. nucl. (NP) if central prod.is requested
5599       IF (ICENTR.GT.0) THEN
5600          CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5601          IF (IBACK.GT.0) GOTO 10
5602       ENDIF
5603
5604 * get initial nucleon-configuration in projectile and target
5605 * rest-system (including Fermi-momenta if requested)
5606       CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5607       MODE = 2
5608       IF (EPROJ.LE.EHADTH) MODE = 3
5609       CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5610
5611       IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5612
5613 * activate HADRIN at low energies (implemented for h-N scattering only)
5614          IF (EPROJ.LE.EHADHI) THEN
5615             IF (EHADTH.LT.ZERO) THEN
5616 *   smooth transition btwn. DPM and HADRIN
5617                FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5618                RR   = DT_RNDM(FRAC)
5619                IF (RR.GT.FRAC) THEN
5620                   IF (IP.EQ.1) THEN
5621                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5622                      IF (IREJ1.GT.0) GOTO 1
5623                      RETURN
5624                   ELSE
5625                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5626                   ENDIF
5627                ENDIF
5628             ELSE
5629 *   fixed threshold for onset of production via HADRIN
5630                IF (EPROJ.LE.EHADTH) THEN
5631                   IF (IP.EQ.1) THEN
5632                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5633                      IF (IREJ1.GT.0) GOTO 1
5634                      RETURN
5635                   ELSE
5636                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5637                   ENDIF
5638                ENDIF
5639             ENDIF
5640          ENDIF
5641  1001    FORMAT(1X,'KKEVNT:   warning! interaction of proj. (m=',
5642      &          I3,') with target (m=',I3,')',/,11X,
5643      &          'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5644      &          'GeV) cannot be handled')
5645
5646 * sampling of momentum-x fractions & flavors of chain ends
5647          CALL DT_SPLPTN(NN)
5648
5649 * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5650          CALL DT_NUC2CM
5651
5652 * collect momenta of chain ends and put them into DTEVT1
5653          CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5654          IF (IREJ1.NE.0) GOTO 1
5655
5656       ENDIF
5657
5658 * handle chains including fragmentation (two-chain approximation)
5659       IF (MCGENE.EQ.1) THEN
5660 *  two-chain approximation
5661          CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5662          IF (IREJ1.NE.0) THEN
5663             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5664             GOTO 1
5665          ENDIF
5666       ELSEIF (MCGENE.EQ.2) THEN
5667 *  multiple-Po exchange including minijets
5668          CALL DT_EVENTB(NCSY,IREJ1)
5669          IF (IREJ1.NE.0) THEN
5670             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5671             GOTO 1
5672          ENDIF
5673       ELSEIF (MCGENE.EQ.3) THEN
5674          STOP ' This version does not contain LEPTO !'
5675
5676       ELSEIF (MCGENE.EQ.4) THEN
5677 *  quasi-elastic neutrino scattering
5678          CALL DT_EVENTD(IREJ1)
5679          IF (IREJ1.NE.0) THEN
5680             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5681             GOTO 1
5682          ENDIF
5683       ELSE
5684          WRITE(LOUT,1002) MCGENE
5685  1002    FORMAT(1X,'KKEVNT:   warning! event-generator',I4,
5686      &         ' not available - program stopped')
5687          STOP
5688       ENDIF
5689
5690       RETURN
5691
5692  9999 CONTINUE
5693       IREJ = 1
5694       RETURN
5695       END
5696
5697 *$ CREATE DT_CHKCEN.FOR
5698 *COPY DT_CHKCEN
5699 *
5700 *===chkcen=============================================================*
5701 *
5702       SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5703
5704 ************************************************************************
5705 * Check of number of involved projectile nucleons if central production*
5706 * is requested.                                                        *
5707 * Adopted from a part of the old KKEVT routine which was written by    *
5708 * J. Ranft/H.-J.Moehring.                                              *
5709 * This version dated 13.01.95 is written by S. Roesler                 *
5710 ************************************************************************
5711
5712       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5713       SAVE
5714
5715       PARAMETER ( LINP = 10 ,
5716      &            LOUT = 6 ,
5717      &            LDAT = 9 )
5718
5719 * statistics
5720       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5721      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5722      &                ICEVTG(8,0:30)
5723
5724 * central particle production, impact parameter biasing
5725       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5726
5727       IBACK = 0
5728
5729 * old version
5730       IF (ICENTR.EQ.2) THEN
5731          IF (IP.LT.IT) THEN
5732             IF (IP.LE.8) THEN
5733                IF (NP.LT.IP-1) IBACK = 1
5734             ELSEIF (IP.LE.16) THEN
5735                IF (NP.LT.IP-2) IBACK = 1
5736             ELSEIF (IP.LE.32) THEN
5737                IF (NP.LT.IP-3) IBACK = 1
5738             ELSEIF (IP.GE.33) THEN
5739                IF (NP.LT.IP-5) IBACK = 1
5740             ENDIF
5741          ELSEIF (IP.EQ.IT) THEN
5742             IF (IP.EQ.32) THEN
5743                IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5744             ELSE
5745                IF (NP.LT.IP-IP/8) IBACK = 1
5746             ENDIF
5747          ELSEIF (ABS(IP-IT).LT.3) THEN
5748             IF (NP.LT.IP-IP/8) IBACK = 1
5749          ENDIF
5750       ELSE
5751 * new version (DPMJET, 5.6.99)
5752          IF (IP.LT.IT) THEN
5753             IF (IP.LE.8) THEN
5754                IF (NP.LT.IP-1) IBACK = 1
5755             ELSEIF (IP.LE.16) THEN
5756                IF (NP.LT.IP-2) IBACK = 1
5757             ELSEIF (IP.LT.32) THEN
5758                IF (NP.LT.IP-3) IBACK = 1
5759             ELSEIF (IP.GE.32) THEN
5760                IF (IT.LE.150) THEN
5761 *   Example: S-Ag
5762                   IF (NP.LT.IP-1) IBACK = 1
5763                ELSE
5764 *   Example: S-Au
5765                   IF (NP.LT.IP) IBACK = 1
5766                ENDIF
5767             ENDIF
5768          ELSEIF (IP.EQ.IT) THEN
5769 *   Example: S-S
5770            IF (IP.EQ.32) THEN
5771               IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5772 *   Example: Pb-Pb
5773            ELSE
5774               IF (NP.LT.IP-IP/4) IBACK = 1
5775            ENDIF
5776          ELSEIF (ABS(IP-IT).LT.3) THEN
5777             IF (NP.LT.IP-IP/8) IBACK = 1
5778          ENDIF
5779       ENDIF
5780
5781       ICCPRO = ICCPRO+1
5782
5783       RETURN
5784       END
5785
5786 *$ CREATE DT_ININUC.FOR
5787 *COPY DT_ININUC
5788 *
5789 *===ininuc=============================================================*
5790 *
5791       SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5792
5793 ************************************************************************
5794 * Samples initial configuration of nucleons in nucleus with mass NMASS *
5795 * including Fermi-momenta (if reqested).                               *
5796 *          ID             BAMJET-code for hadrons (instead of nuclei)  *
5797 *          NMASS          mass number of nucleus (number of nucleons)  *
5798 *          NCH            charge of nucleus                            *
5799 *          COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5800 *          JS(NMASS) > 0  nucleon undergoes nucleon-nucleon interact.  *
5801 *          IMODE = 1      projectile nucleus                           *
5802 *                = 2      target     nucleus                           *
5803 *                = 3      target     nucleus (E_lab<E_thr for HADRIN)  *
5804 * Adopted from a part of the old KKEVT routine which was written by    *
5805 * J. Ranft/H.-J.Moehring.                                              *
5806 * This version dated 13.01.95 is written by S. Roesler                 *
5807 ************************************************************************
5808
5809       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5810       SAVE
5811
5812       PARAMETER ( LINP = 10 ,
5813      &            LOUT = 6 ,
5814      &            LDAT = 9 )
5815
5816       PARAMETER (FM2MM=1.0D-12)
5817
5818       PARAMETER ( MAXNCL = 260,
5819
5820      &            MAXVQU = MAXNCL,
5821      &            MAXSQU = 20*MAXVQU,
5822      &            MAXINT = MAXVQU+MAXSQU)
5823
5824 * event history
5825
5826       PARAMETER (NMXHKK=200000)
5827
5828       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5829      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5830      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5831
5832 * extended event history
5833       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5834      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5835      &                IHIST(2,NMXHKK)
5836
5837 * flags for input different options
5838       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5839       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5840      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5841
5842 * auxiliary common for chain system storage (DTUNUC 1.x)
5843       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5844
5845 * nuclear potential
5846       LOGICAL LFERMI
5847       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5848      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5849      &                ETACOU(2),ICOUL,LFERMI
5850
5851 * properties of photon/lepton projectiles
5852       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5853
5854 * particle properties (BAMJET index convention)
5855       CHARACTER*8  ANAME
5856       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5857      &                IICH(210),IIBAR(210),K1(210),K2(210)
5858
5859 * Glauber formalism: collision properties
5860       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5861      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5862
5863 * flavors of partons (DTUNUC 1.x)
5864       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5865      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5866      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5867      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5868      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5869      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5870      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5871
5872 * interface HADRIN-DPM
5873       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5874
5875       DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5876
5877 * number of neutrons
5878       NNEU = NMASS-NCH
5879 * initializations
5880       NP = 0
5881       NN = 0
5882       DO 1 K=1,4
5883          PFTOT(K) = 0.0D0
5884     1 CONTINUE
5885       MODE   = IMODE
5886       IF (IMODE.GT.2) MODE = 2
5887 **sr 29.5. new NPOINT(1)-definition
5888 C     IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5889 **
5890       NHADRI = 0
5891       NC     = NHKK
5892
5893 * get initial configuration
5894       DO 2 I=1,NMASS
5895          NHKK = NHKK+1
5896          IF (JS(I).GT.0) THEN
5897             ISTHKK(NHKK) = 10+MODE
5898             IF (IMODE.EQ.3) THEN
5899 *   additional treatment if HADRIN-generator is requested
5900                NHADRI = NHADRI+1
5901                IF (NHADRI.EQ.1) IDXTA  = NHKK
5902                IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5903             ENDIF
5904          ELSE
5905             ISTHKK(NHKK) = 12+MODE
5906          ENDIF
5907          IF (NMASS.GE.2) THEN
5908 *   treatment for nuclei
5909             FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5910             RR   = DT_RNDM(FRAC)
5911             IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5912                IDX = 8
5913                NN  = NN+1
5914             ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5915                IDX = 1
5916                NP  = NP+1
5917             ELSEIF (NN.LT.NNEU) THEN
5918                IDX = 8
5919                NN  = NN+1
5920             ELSEIF (NP.LT.NCH)  THEN
5921                IDX = 1
5922                NP  = NP+1
5923             ENDIF
5924             IDHKK(NHKK) = IDT_IPDGHA(IDX)
5925             IDBAM(NHKK) = IDX
5926             IF (MODE.EQ.1) THEN
5927                IPOSP(I)  = NHKK
5928                KKPROJ(I) = IDX
5929             ELSE
5930                IPOST(I)  = NHKK
5931                KKTARG(I) = IDX
5932             ENDIF
5933             IF (IDX.EQ.1) THEN
5934                PFER = PFERMP(MODE)
5935                PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5936             ELSE
5937                PFER = PFERMN(MODE)
5938                PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5939             ENDIF
5940             CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5941             DO 3 K=1,4
5942                PFTOT(K) = PFTOT(K)+PF(K)
5943                PHKK(K,NHKK) = PF(K)
5944     3       CONTINUE
5945             PHKK(5,NHKK) = AAM(IDX)
5946          ELSE
5947 *   treatment for hadrons
5948             IDHKK(NHKK)  = IDT_IPDGHA(ID)
5949             IDBAM(NHKK)  = ID
5950             PHKK(4,NHKK) = AAM(ID)
5951             PHKK(5,NHKK) = AAM(ID)
5952 C* VDM assumption
5953 C            IF (IDHKK(NHKK).EQ.22) THEN
5954 C               PHKK(4,NHKK) = AAM(33)
5955 C               PHKK(5,NHKK) = AAM(33)
5956 C            ENDIF
5957             IF (MODE.EQ.1) THEN
5958                IPOSP(I)  = NHKK
5959                KKPROJ(I) = ID
5960                PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5961             ELSE
5962                IPOST(I)  = NHKK
5963                KKTARG(I) = ID
5964             ENDIF
5965          ENDIF
5966          DO 4 K=1,3
5967             VHKK(K,NHKK) = COORD(K,I)*FM2MM
5968             WHKK(K,NHKK) = COORD(K,I)*FM2MM
5969     4    CONTINUE
5970          IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5971          IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5972          VHKK(4,NHKK) = 0.0D0
5973          WHKK(4,NHKK) = 0.0D0
5974     2 CONTINUE
5975
5976 * balance Fermi-momenta
5977       IF (NMASS.GE.2) THEN
5978          DO 5 I=1,NMASS
5979             NC = NC+1
5980             DO 6 K=1,3
5981                PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5982     6       CONTINUE
5983             PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5984      &                        PHKK(2,NC)**2+PHKK(3,NC)**2)
5985     5    CONTINUE
5986       ENDIF
5987
5988       RETURN
5989       END
5990
5991 *$ CREATE DT_FER4M.FOR
5992 *COPY DT_FER4M
5993 *
5994 *===fer4m==============================================================*
5995 *
5996       SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
5997
5998 ************************************************************************
5999 * Sampling of nucleon Fermi-momenta from distributions at T=0.         *
6000 *                                   processed by S. Roesler, 17.10.95  *
6001 ************************************************************************
6002
6003       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6004       SAVE
6005
6006       PARAMETER ( LINP = 10 ,
6007      &            LOUT = 6 ,
6008      &            LDAT = 9 )
6009
6010       LOGICAL LSTART
6011
6012 * particle properties (BAMJET index convention)
6013       CHARACTER*8  ANAME
6014       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6015      &                IICH(210),IIBAR(210),K1(210),K2(210)
6016
6017 * nuclear potential
6018       LOGICAL LFERMI
6019       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
6020      &                EBINDP(2),EBINDN(2),EPOT(2,210),
6021      &                ETACOU(2),ICOUL,LFERMI
6022
6023       DATA LSTART /.TRUE./
6024
6025       ILOOP = 0
6026       IF (LFERMI) THEN
6027          IF (LSTART) THEN
6028             WRITE(LOUT,1000)
6029  1000       FORMAT(/,1X,'FER4M:   sampling of Fermi-momenta activated')
6030             LSTART = .FALSE.
6031          ENDIF
6032     1    CONTINUE
6033          CALL DT_DFERMI(PABS)
6034          PABS = PFERM*PABS
6035 C        IF (PABS.GE.PBIND) THEN
6036 C           ILOOP = ILOOP+1
6037 C           IF (MOD(ILOOP,500).EQ.0) THEN
6038 C              WRITE(LOUT,1001) PABS,PBIND,ILOOP
6039 C1001          FORMAT(1X,'FER4M:    Fermi-mom. corr. for binding',
6040 C    &                ' energy ',2E12.3,I6)
6041 C           ENDIF
6042 C           GOTO 1
6043 C        ENDIF
6044          CALL DT_DPOLI(POLC,POLS)
6045          CALL DT_DSFECF(SFE,CFE)
6046          CXTA = POLS*CFE
6047          CYTA = POLS*SFE
6048          CZTA = POLC
6049          ET   = SQRT(PABS*PABS+AAM(KT)**2)
6050          PXT  = CXTA*PABS
6051          PYT  = CYTA*PABS
6052          PZT  = CZTA*PABS
6053       ELSE
6054          ET   = AAM(KT)
6055          PXT  = 0.0D0
6056          PYT  = 0.0D0
6057          PZT  = 0.0D0
6058       ENDIF
6059
6060       RETURN
6061       END
6062
6063 *$ CREATE DT_NUC2CM.FOR
6064 *COPY DT_NUC2CM
6065 *
6066 *===nuc2cm=============================================================*
6067 *
6068       SUBROUTINE DT_NUC2CM
6069
6070 ************************************************************************
6071 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.-   *
6072 * nucl. cms. (This subroutine replaces NUCMOM.)                        *
6073 * This version dated 15.01.95 is written by S. Roesler                 *
6074 ************************************************************************
6075
6076       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6077       SAVE
6078
6079       PARAMETER ( LINP = 10 ,
6080      &            LOUT = 6 ,
6081      &            LDAT = 9 )
6082
6083       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
6084
6085 * event history
6086
6087       PARAMETER (NMXHKK=200000)
6088
6089       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6090      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6091      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6092
6093 * extended event history
6094       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6095      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6096      &                IHIST(2,NMXHKK)
6097
6098 * statistics
6099       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6100      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6101      &                ICEVTG(8,0:30)
6102
6103 * properties of photon/lepton projectiles
6104       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
6105
6106 * particle properties (BAMJET index convention)
6107       CHARACTER*8  ANAME
6108       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6109      &                IICH(210),IIBAR(210),K1(210),K2(210)
6110
6111 * Glauber formalism: collision properties
6112       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
6113      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
6114 **temporary
6115
6116 * statistics: Glauber-formalism
6117       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
6118 **
6119
6120       ICWP = 0
6121       ICWT = 0
6122       NWTACC = 0
6123       NWAACC = 0
6124       NWBACC = 0
6125
6126       NPOINT(1) = NHKK+1
6127       NEND      = NHKK
6128       DO 1 I=1,NEND
6129          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
6130             IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
6131             IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
6132             MODE = ISTHKK(I)-9
6133 C            IF (IDHKK(I).EQ.22) THEN
6134 C* VDM assumption
6135 C               PEIN = AAM(33)
6136 C               IDB  = 33
6137 C            ELSE
6138 C               PEIN = PHKK(4,I)
6139 C               IDB  = IDBAM(I)
6140 C            ENDIF
6141 C            CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
6142 C     &           PX,PY,PZ,PE,IDB,MODE)
6143             IF (PHKK(5,I).GT.ZERO) THEN
6144                CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
6145      &              PX,PY,PZ,PE,IDBAM(I),MODE)
6146             ELSE
6147                PX = PGAMM(1)
6148                PY = PGAMM(2)
6149                PZ = PGAMM(3)
6150                PE = PGAMM(4)
6151             ENDIF
6152             IST = ISTHKK(I)-2
6153             ID  = IDHKK(I)
6154 C* VDM assumption
6155 C            IF (ID.EQ.22) ID = 113
6156             CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
6157             IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
6158             IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
6159          ENDIF
6160     1 CONTINUE
6161
6162       NWTACC = MAX(NWAACC,NWBACC)
6163       ICDPR  = ICDPR+ICWP
6164       ICDTA  = ICDTA+ICWT
6165 **temporary
6166       IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
6167          CALL DT_EVTOUT(4)
6168          STOP
6169       ENDIF
6170
6171       RETURN
6172       END
6173
6174 *$ CREATE DT_SPLPTN.FOR
6175 *COPY DT_SPLPTN
6176 *
6177 *===splptn=============================================================*
6178 *
6179       SUBROUTINE DT_SPLPTN(NN)
6180
6181 ************************************************************************
6182 * SamPLing of ParToN momenta and flavors.                              *
6183 * This version dated 15.01.95 is written by S. Roesler                 *
6184 ************************************************************************
6185
6186       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6187       SAVE
6188
6189       PARAMETER ( LINP = 10 ,
6190      &            LOUT = 6 ,
6191      &            LDAT = 9 )
6192
6193 * Lorentz-parameters of the current interaction
6194       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
6195      &                UMO,PPCM,EPROJ,PPROJ
6196
6197 * sample flavors of sea-quarks
6198       CALL DT_SPLFLA(NN,1)
6199
6200 * sample x-values of partons at chain ends
6201       ECM = UMO
6202       CALL DT_XKSAMP(NN,ECM)
6203
6204 * samle flavors
6205       CALL DT_SPLFLA(NN,2)
6206
6207       RETURN
6208       END
6209
6210 *$ CREATE DT_SPLFLA.FOR
6211 *COPY DT_SPLFLA
6212 *
6213 *===splfla=============================================================*
6214 *
6215       SUBROUTINE DT_SPLFLA(NN,MODE)
6216
6217 ************************************************************************
6218 * SamPLing of FLAvors of partons at chain ends.                        *
6219 * This subroutine replaces FLKSAA/FLKSAM.                              *
6220 *            NN            number of nucleon-nucleon interactions      *
6221 *            MODE = 1      sea-flavors                                 *
6222 *                 = 2      valence-flavors                             *
6223 * Based on the original version written by J. Ranft/H.-J. Moehring.    *
6224 * This version dated 16.01.95 is written by S. Roesler                 *
6225 ************************************************************************
6226
6227       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6228       SAVE
6229
6230       PARAMETER ( LINP = 10 ,
6231      &            LOUT = 6 ,
6232      &            LDAT = 9 )
6233
6234       PARAMETER ( MAXNCL = 260,
6235
6236      &            MAXVQU = MAXNCL,
6237      &            MAXSQU = 20*MAXVQU,
6238      &            MAXINT = MAXVQU+MAXSQU)
6239
6240 * flavors of partons (DTUNUC 1.x)
6241       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6242      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6243      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
6244      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6245      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
6246      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6247      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
6248
6249 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6250       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6251      &                IXPV,IXPS,IXTV,IXTS,
6252      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
6253      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
6254      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
6255      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
6256      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
6257      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
6258      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
6259      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
6260
6261 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6262       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6263      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6264
6265 * particle properties (BAMJET index convention)
6266       CHARACTER*8  ANAME
6267       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6268      &                IICH(210),IIBAR(210),K1(210),K2(210)
6269
6270 * various options for treatment of partons (DTUNUC 1.x)
6271 * (chain recombination, Cronin,..)
6272       LOGICAL LCO2CR,LINTPT
6273       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6274      &                LCO2CR,LINTPT
6275
6276       IF (MODE.EQ.1) THEN
6277 * sea-flavors
6278          DO 1 I=1,NN
6279             IPSQ(I)  = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6280             IPSAQ(I) = -IPSQ(I)
6281     1    CONTINUE
6282          DO 2 I=1,NN
6283             ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6284             ITSAQ(I)= -ITSQ(I)
6285     2    CONTINUE
6286       ELSEIF (MODE.EQ.2) THEN
6287 * valence flavors
6288          DO 3 I=1,IXPV
6289             CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
6290     3    CONTINUE
6291          DO 4 I=1,IXTV
6292             CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
6293     4    CONTINUE
6294       ENDIF
6295
6296       RETURN
6297       END
6298
6299 *$ CREATE DT_GETPTN.FOR
6300 *COPY DT_GETPTN
6301 *
6302 *===getptn=============================================================*
6303 *
6304       SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
6305
6306 ************************************************************************
6307 * This subroutine collects partons at chain ends from temporary        *
6308 * commons and puts them into DTEVT1.                                   *
6309 * This version dated 15.01.95 is written by S. Roesler                 *
6310 ************************************************************************
6311
6312       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6313       SAVE
6314
6315       PARAMETER ( LINP = 10 ,
6316      &            LOUT = 6 ,
6317      &            LDAT = 9 )
6318
6319       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
6320
6321       LOGICAL LCHK
6322
6323       PARAMETER ( MAXNCL = 260,
6324
6325      &            MAXVQU = MAXNCL,
6326      &            MAXSQU = 20*MAXVQU,
6327      &            MAXINT = MAXVQU+MAXSQU)
6328
6329 * event history
6330
6331       PARAMETER (NMXHKK=200000)
6332
6333       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6334      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6335      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6336
6337 * extended event history
6338       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6339      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6340      &                IHIST(2,NMXHKK)
6341
6342 * flags for input different options
6343       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6344       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6345      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6346
6347 * auxiliary common for chain system storage (DTUNUC 1.x)
6348       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
6349
6350 * statistics
6351       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6352      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6353      &                ICEVTG(8,0:30)
6354
6355 * flags for diffractive interactions (DTUNUC 1.x)
6356       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6357
6358 * x-values of partons (DTUNUC 1.x)
6359       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
6360      &                XTVQ(MAXVQU),XTVD(MAXVQU),
6361      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
6362      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
6363
6364 * flavors of partons (DTUNUC 1.x)
6365       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6366      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6367      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
6368      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6369      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
6370      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6371      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
6372
6373 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6374       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6375      &                IXPV,IXPS,IXTV,IXTS,
6376      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
6377      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
6378      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
6379      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
6380      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
6381      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
6382      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
6383      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
6384
6385 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6386       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6387      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6388
6389       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6390
6391       DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6392
6393       IREJ      = 0
6394       NCSY      = 0
6395       NPOINT(2) = NHKK+1
6396
6397 * sea-sea chains
6398       DO 10 I=1,NSS
6399          IF (ISKPCH(1,I).EQ.99) GOTO 10
6400          ICCHAI(1,1) = ICCHAI(1,1)+2
6401          IDXP = INTSS1(I)
6402          IDXT = INTSS2(I)
6403          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6404          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6405          DO 11 K=1,4
6406             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6407             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6408             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6409             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6410    11    CONTINUE
6411          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6412      &                                  +(PP1(3)+PT1(3))**2)
6413          ECH   = PP1(4)+PT1(4)
6414          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6415          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6416      &                                  +(PP2(3)+PT2(3))**2)
6417          ECH   = PP2(4)+PT2(4)
6418          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6419          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6420             AM1 = SQRT(AM1)
6421             AM2 = SQRT(AM2)
6422             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6423 C              WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6424  5000          FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6425             ENDIF
6426          ELSE
6427             WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6428          ENDIF
6429          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6430          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6431          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6432          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6433          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6434      &                                                    0,0,1)
6435          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6436      &                                                    0,0,1)
6437          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6438      &                                                    0,0,1)
6439          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6440      &                                                    0,0,1)
6441          NCSY = NCSY+1
6442    10 CONTINUE
6443
6444 * disea-sea chains
6445       DO 20 I=1,NDS
6446          IF (ISKPCH(2,I).EQ.99) GOTO 20
6447          ICCHAI(1,2) = ICCHAI(1,2)+2
6448          IDXP = INTDS1(I)
6449          IDXT = INTDS2(I)
6450          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6451          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6452          DO 21 K=1,4
6453             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6454             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6455             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6456             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6457    21    CONTINUE
6458          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6459      &                                  +(PP1(3)+PT1(3))**2)
6460          ECH   = PP1(4)+PT1(4)
6461          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6462          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6463      &                                  +(PP2(3)+PT2(3))**2)
6464          ECH   = PP2(4)+PT2(4)
6465          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6466          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6467             AM1 = SQRT(AM1)
6468             AM2 = SQRT(AM2)
6469             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6470 C              WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6471  5001          FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6472             ENDIF
6473          ELSE
6474             WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6475          ENDIF
6476          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6477          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6478          IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6479          IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6480          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6481      &                                                    0,0,2)
6482          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6483      &                                                    0,0,2)
6484          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6485      &                                                    0,0,2)
6486          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6487      &                                                    0,0,2)
6488          NCSY = NCSY+1
6489    20 CONTINUE
6490
6491 * sea-disea chains
6492       DO 30 I=1,NSD
6493          IF (ISKPCH(3,I).EQ.99) GOTO 30
6494          ICCHAI(1,3) = ICCHAI(1,3)+2
6495          IDXP = INTSD1(I)
6496          IDXT = INTSD2(I)
6497          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6498          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6499          DO 31 K=1,4
6500             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6501             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6502             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6503             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6504    31    CONTINUE
6505          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6506      &                                  +(PP1(3)+PT1(3))**2)
6507          ECH   = PP1(4)+PT1(4)
6508          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6509          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6510      &                                  +(PP2(3)+PT2(3))**2)
6511          ECH   = PP2(4)+PT2(4)
6512          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6513          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6514             AM1 = SQRT(AM1)
6515             AM2 = SQRT(AM2)
6516             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6517 C              WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6518  5002          FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6519             ENDIF
6520          ELSE
6521             WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6522          ENDIF
6523          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6524          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6525          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6526          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6527          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6528      &                                                    0,0,3)
6529          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6530      &                                                    0,0,3)
6531          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6532      &                                                    0,0,3)
6533          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6534      &                                                    0,0,3)
6535          NCSY = NCSY+1
6536    30 CONTINUE
6537
6538 * disea-valence chains
6539       DO 50 I=1,NDV
6540          IF (ISKPCH(5,I).EQ.99) GOTO 50
6541          ICCHAI(1,5) = ICCHAI(1,5)+2
6542          IDXP = INTDV1(I)
6543          IDXT = INTDV2(I)
6544          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6545          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6546          DO 51 K=1,4
6547             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6548             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6549             PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6550             PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6551    51    CONTINUE
6552          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6553      &                                  +(PP1(3)+PT1(3))**2)
6554          ECH   = PP1(4)+PT1(4)
6555          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6556          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6557      &                                  +(PP2(3)+PT2(3))**2)
6558          ECH   = PP2(4)+PT2(4)
6559          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6560          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6561             AM1 = SQRT(AM1)
6562             AM2 = SQRT(AM2)
6563             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6564 C              WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6565  5003          FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6566             ENDIF
6567          ELSE
6568             WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6569          ENDIF
6570          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6571          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6572          IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6573          IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6574          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6575      &                                                    0,0,5)
6576          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6577      &                                                    0,0,5)
6578          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6579      &                                                    0,0,5)
6580          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6581      &                                                    0,0,5)
6582          NCSY = NCSY+1
6583    50 CONTINUE
6584
6585 * valence-sea chains
6586       DO 60 I=1,NVS
6587          IF (ISKPCH(6,I).EQ.99) GOTO 60
6588          ICCHAI(1,6) = ICCHAI(1,6)+2
6589          IDXP = INTVS1(I)
6590          IDXT = INTVS2(I)
6591          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6592          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6593          DO 61 K=1,4
6594             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6595             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6596             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6597             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6598    61    CONTINUE
6599          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6600          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6601          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6602          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6603          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6604          IF (LCHK) THEN
6605             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6606      &                                                       0,0,6)
6607             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6608      &                                                       0,0,6)
6609             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6610      &                                                       0,0,6)
6611             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6612      &                                                       0,0,6)
6613             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6614      &                                     +(PP1(3)+PT1(3))**2)
6615             ECH   = PP1(4)+PT1(4)
6616             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6617             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6618      &                                     +(PP2(3)+PT2(3))**2)
6619             ECH   = PP2(4)+PT2(4)
6620             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6621          ELSE
6622             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6623      &                                                       0,0,6)
6624             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6625      &                                                       0,0,6)
6626             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6627      &                                                       0,0,6)
6628             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6629      &                                                       0,0,6)
6630             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6631      &                                     +(PP1(3)+PT2(3))**2)
6632             ECH   = PP1(4)+PT2(4)
6633             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6634             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6635      &                                     +(PP2(3)+PT1(3))**2)
6636             ECH   = PP2(4)+PT1(4)
6637             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6638          ENDIF
6639          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6640             AM1 = SQRT(AM1)
6641             AM2 = SQRT(AM2)
6642             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6643 C              WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6644  5004          FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6645             ENDIF
6646          ELSE
6647             WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6648          ENDIF
6649          NCSY = NCSY+1
6650    60 CONTINUE
6651
6652 * sea-valence chains
6653       DO 40 I=1,NSV
6654          IF (ISKPCH(4,I).EQ.99) GOTO 40
6655          ICCHAI(1,4) = ICCHAI(1,4)+2
6656          IDXP = INTSV1(I)
6657          IDXT = INTSV2(I)
6658          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6659          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6660          DO 41 K=1,4
6661             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6662             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6663             PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6664             PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6665    41    CONTINUE
6666          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6667      &                                  +(PP1(3)+PT1(3))**2)
6668          ECH   = PP1(4)+PT1(4)
6669          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6670          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6671      &                                  +(PP2(3)+PT2(3))**2)
6672          ECH   = PP2(4)+PT2(4)
6673          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6674          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6675             AM1 = SQRT(AM1)
6676             AM2 = SQRT(AM2)
6677             IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6678 C              WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6679  5005          FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6680             ENDIF
6681          ELSE
6682             WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6683          ENDIF
6684          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6685          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6686          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6687          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6688          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6689      &                                                    0,0,4)
6690          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6691      &                                                    0,0,4)
6692          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6693      &                                                    0,0,4)
6694          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6695      &                                                    0,0,4)
6696          NCSY = NCSY+1
6697    40 CONTINUE
6698
6699 * valence-disea chains
6700       DO 70 I=1,NVD
6701          IF (ISKPCH(7,I).EQ.99) GOTO 70
6702          ICCHAI(1,7) = ICCHAI(1,7)+2
6703          IDXP = INTVD1(I)
6704          IDXT = INTVD2(I)
6705          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6706          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6707          DO 71 K=1,4
6708             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6709             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6710             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6711             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6712    71    CONTINUE
6713          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6714          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6715          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6716          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6717          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6718          IF (LCHK) THEN
6719             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6720      &                                                       0,0,7)
6721             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6722      &                                                       0,0,7)
6723             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6724      &                                                       0,0,7)
6725             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6726      &                                                       0,0,7)
6727             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6728      &                                     +(PP1(3)+PT1(3))**2)
6729             ECH   = PP1(4)+PT1(4)
6730             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6731             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6732      &                                     +(PP2(3)+PT2(3))**2)
6733             ECH   = PP2(4)+PT2(4)
6734             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6735          ELSE
6736             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6737      &                                                       0,0,7)
6738             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6739      &                                                       0,0,7)
6740             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6741      &                                                       0,0,7)
6742             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6743      &                                                       0,0,7)
6744             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6745      &                                     +(PP1(3)+PT2(3))**2)
6746             ECH   = PP1(4)+PT2(4)
6747             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6748             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6749      &                                     +(PP2(3)+PT1(3))**2)
6750             ECH   = PP2(4)+PT1(4)
6751             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6752          ENDIF
6753          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6754             AM1 = SQRT(AM1)
6755             AM2 = SQRT(AM2)
6756             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6757 C              WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6758  5006          FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6759             ENDIF
6760          ELSE
6761             WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6762          ENDIF
6763          NCSY = NCSY+1
6764    70 CONTINUE
6765
6766 * valence-valence chains
6767       DO 80 I=1,NVV
6768          IF (ISKPCH(8,I).EQ.99) GOTO 80
6769          ICCHAI(1,8) = ICCHAI(1,8)+2
6770          IDXP = INTVV1(I)
6771          IDXT = INTVV2(I)
6772          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6773          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6774          DO 81 K=1,4
6775             PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6776             PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6777             PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6778             PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6779    81    CONTINUE
6780          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6781          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6782          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6783          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6784
6785 * check for diffractive event
6786          IDIFF = 0
6787          IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6788      &        (IP.EQ.1).AND.(NN.EQ.1)) THEN
6789             DO 800 K=1,4
6790                PP(K) = PP1(K)+PP2(K)
6791                PT(K) = PT1(K)+PT2(K)
6792   800       CONTINUE
6793             ISTCK = NHKK
6794             CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6795      &                  IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6796 C           IF (IREJ1.NE.0) GOTO 9999
6797             IF (IREJ1.NE.0) THEN
6798                IDIFF = 0
6799                NHKK  = ISTCK
6800             ENDIF
6801          ELSE
6802             IDIFF = 0
6803          ENDIF
6804
6805          IF (IDIFF.EQ.0) THEN
6806 *   valence-valence chain system
6807             CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6808             IF (LCHK) THEN
6809 *    baryon-baryon
6810                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6811      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6812                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6813      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6814                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6815      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6816                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6817      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6818                PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6819      &                                        +(PP1(3)+PT1(3))**2)
6820                ECH   = PP1(4)+PT1(4)
6821                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6822                PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6823      &                                        +(PP2(3)+PT2(3))**2)
6824                ECH   = PP2(4)+PT2(4)
6825                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6826             ELSE
6827 *    antibaryon-baryon
6828                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6829      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6830                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6831      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6832                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6833      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6834                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6835      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6836                PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6837      &                                        +(PP1(3)+PT2(3))**2)
6838                ECH   = PP1(4)+PT2(4)
6839                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6840                PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6841      &                                        +(PP2(3)+PT1(3))**2)
6842                ECH   = PP2(4)+PT1(4)
6843                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6844             ENDIF
6845             IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6846                AM1 = SQRT(AM1)
6847                AM2 = SQRT(AM2)
6848                IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6849 C                 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6850  5007             FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6851                ENDIF
6852             ELSE
6853                WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6854             ENDIF
6855             NCSY = NCSY+1
6856          ENDIF
6857    80 CONTINUE
6858       IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6859
6860 * energy-momentum & flavor conservation check
6861       IF (ABS(IDIFF).NE.1) THEN
6862          IF (IDIFF.NE.0) THEN
6863             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6864      &                                              1,3,10,IREJ)
6865          ELSE
6866             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6867      &                                              1,3,10,IREJ)
6868          ENDIF
6869          IF (IREJ.NE.0) THEN
6870             CALL DT_EVTOUT(4)
6871             STOP
6872          ENDIF
6873       ENDIF
6874
6875       RETURN
6876
6877  9999 CONTINUE
6878       IREJ  = 1
6879       RETURN
6880       END
6881
6882 *$ CREATE DT_CHKCSY.FOR
6883 *COPY DT_CHKCSY
6884 *
6885 *===chkcsy=============================================================*
6886 *
6887       SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6888
6889 ************************************************************************
6890 * CHeCk Chain SYstem for consistency of partons at chain ends.         *
6891 *            ID1,ID2        PDG-numbers of partons at chain ends       *
6892 *            LCHK = .true.  consistent chain                           *
6893 *                 = .false. inconsistent chain                         *
6894 * This version dated 18.01.95 is written by S. Roesler                 *
6895 ************************************************************************
6896
6897       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6898       SAVE
6899
6900       PARAMETER ( LINP = 10 ,
6901      &            LOUT = 6 ,
6902      &            LDAT = 9 )
6903
6904       LOGICAL LCHK
6905
6906       LCHK = .TRUE.
6907
6908 * q-aq chain
6909       IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6910          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6911 * q-qq, aq-aqaq chain
6912       ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6913      &        ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6914          IF (ID1*ID2.LT.0) LCHK = .FALSE.
6915 * qq-aqaq chain
6916       ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6917          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6918       ENDIF
6919
6920       RETURN
6921       END
6922
6923 *$ CREATE DT_EVENTA.FOR
6924 *COPY DT_EVENTA
6925 *
6926 *===eventa=============================================================*
6927 *
6928       SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6929
6930 ************************************************************************
6931 * Treatment of nucleon-nucleon interactions in a two-chain             *
6932 * approximation.                                                       *
6933 *  (input) ID       BAMJET-index of projectile hadron (in case of      *
6934 *                   h-K scattering)                                    *
6935 *          IP/IT    mass number of projectile/target nucleus           *
6936 *          NCSY     number of two chain systems                        *
6937 *          IREJ     rejection flag                                     *
6938 * This version dated 15.01.95 is written by S. Roesler                 *
6939 ************************************************************************
6940
6941       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6942       SAVE
6943
6944       PARAMETER ( LINP = 10 ,
6945      &            LOUT = 6 ,
6946      &            LDAT = 9 )
6947
6948       PARAMETER (TINY10=1.0D-10)
6949
6950 * event history
6951
6952       PARAMETER (NMXHKK=200000)
6953
6954       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6955      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6956      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6957
6958 * extended event history
6959       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6960      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6961      &                IHIST(2,NMXHKK)
6962
6963 * rejection counter
6964       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6965      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6966      &                IREXCI(3),IRDIFF(2),IRINC
6967
6968 * flags for diffractive interactions (DTUNUC 1.x)
6969       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6970
6971 * particle properties (BAMJET index convention)
6972       CHARACTER*8  ANAME
6973       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6974      &                IICH(210),IIBAR(210),K1(210),K2(210)
6975
6976 * flags for input different options
6977       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6978       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6979      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6980
6981 * various options for treatment of partons (DTUNUC 1.x)
6982 * (chain recombination, Cronin,..)
6983       LOGICAL LCO2CR,LINTPT
6984       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6985      &                LCO2CR,LINTPT
6986
6987       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6988
6989       IREJ      = 0
6990       NPOINT(3) = NHKK+1
6991
6992 * skip following treatment for low-mass diffraction
6993       IF (ABS(IFLAGD).EQ.1) THEN
6994          NPOINT(3) = NPOINT(2)
6995          GOTO 5
6996       ENDIF
6997
6998 * multiple scattering of chain ends
6999       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
7000       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
7001
7002       NC = NPOINT(2)
7003 * get a two-chain system from DTEVT1
7004       DO 3 I=1,NCSY
7005          IFP1 = IDHKK(NC)
7006          IFT1 = IDHKK(NC+1)
7007          IFP2 = IDHKK(NC+2)
7008          IFT2 = IDHKK(NC+3)
7009          DO 4 K=1,4
7010             PP1(K) = PHKK(K,NC)
7011             PT1(K) = PHKK(K,NC+1)
7012             PP2(K) = PHKK(K,NC+2)
7013             PT2(K) = PHKK(K,NC+3)
7014     4    CONTINUE
7015          MOP1 = NC
7016          MOT1 = NC+1
7017          MOP2 = NC+2
7018          MOT2 = NC+3
7019          CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
7020      &               IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
7021          IF (IREJ1.GT.0) THEN
7022             IRHHA = IRHHA+1
7023             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
7024             GOTO 9999
7025          ENDIF
7026          NC = NC+4
7027     3 CONTINUE
7028
7029 * meson/antibaryon projectile:
7030 * sample single-chain valence-valence systems (Reggeon contrib.)
7031       IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
7032          IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
7033       ENDIF
7034
7035       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7036 * check DTEVT1 for remaining resonance mass corrections
7037          CALL DT_EVTRES(IREJ1)
7038          IF (IREJ1.GT.0) THEN
7039             IRRES(1) = IRRES(1)+1
7040             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
7041             GOTO 9999
7042          ENDIF
7043       ENDIF
7044
7045 * assign p_t to two-"chain" systems consisting of two resonances only
7046 * since only entries for chains will be affected, this is obsolete
7047 * in case of JETSET-fragmetation
7048       CALL DT_RESPT
7049
7050 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
7051       IF (LCO2CR) CALL DT_COM2CR
7052
7053     5 CONTINUE
7054
7055 * fragmentation of the complete event
7056 **uncomment for internal phojet-fragmentation
7057 C     CALL DT_EVTFRA(IREJ1)
7058       CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
7059       IF (IREJ1.GT.0) THEN
7060          IRFRAG = IRFRAG+1
7061          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
7062          GOTO 9999
7063       ENDIF
7064
7065 * decay of possible resonances (should be obsolete)
7066       CALL DT_DECAY1
7067
7068       RETURN
7069
7070  9999 CONTINUE
7071       IREVT = IREVT+1
7072       IREJ  = 1
7073       RETURN
7074       END
7075
7076 *$ CREATE DT_GETCSY.FOR
7077 *COPY DT_GETCSY
7078 *
7079 *===getcsy=============================================================*
7080 *
7081       SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
7082      &                  IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
7083
7084 ************************************************************************
7085 * This version dated 15.01.95 is written by S. Roesler                 *
7086 ************************************************************************
7087
7088       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7089       SAVE
7090
7091       PARAMETER ( LINP = 10 ,
7092      &            LOUT = 6 ,
7093      &            LDAT = 9 )
7094
7095       PARAMETER (TINY10=1.0D-10)
7096
7097 * event history
7098
7099       PARAMETER (NMXHKK=200000)
7100
7101       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7102      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7103      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7104
7105 * extended event history
7106       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7107      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7108      &                IHIST(2,NMXHKK)
7109
7110 * rejection counter
7111       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7112      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7113      &                IREXCI(3),IRDIFF(2),IRINC
7114
7115 * flags for input different options
7116       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7117       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7118      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7119
7120 * flags for diffractive interactions (DTUNUC 1.x)
7121       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
7122
7123       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
7124      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
7125
7126       IREJ  = 0
7127
7128 * get quark content of partons
7129       DO 1 I=1,2
7130          IFP1(I) = 0
7131          IFP2(I) = 0
7132          IFT1(I) = 0
7133          IFT2(I) = 0
7134     1 CONTINUE
7135       IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
7136       IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
7137       IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
7138       IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
7139       IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
7140       IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
7141       IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
7142       IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
7143
7144 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
7145       IDCH1 = 2
7146       IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
7147       IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
7148       IDCH2 = 2
7149       IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
7150       IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
7151
7152 * store initial configuration for energy-momentum cons. check
7153       IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
7154
7155 * sample intrinsic p_t at chain-ends
7156       CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
7157      &            PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
7158      &            AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
7159       IF (IREJ1.NE.0) THEN
7160          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
7161          IRPT = IRPT+1
7162          GOTO 9999
7163       ENDIF
7164
7165 C      IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7166 C         IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
7167 C* check second chain for resonance
7168 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7169 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
7170 C            IF (IREJ1.NE.0) GOTO 9999
7171 C            IF (IDR2.NE.0) THEN
7172 C               CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7173 C     &                     AMCH2,AMCH2N,AMCH1,IREJ1)
7174 C               IF (IREJ1.NE.0) GOTO 9999
7175 C            ENDIF
7176 C* check first chain for resonance
7177 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7178 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
7179 C            IF (IREJ1.NE.0) GOTO 9999
7180 C            IF (IDR1.NE.0) IDR1 = 100*IDR1
7181 C         ELSE
7182 C* check first chain for resonance
7183 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7184 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
7185 C            IF (IREJ1.NE.0) GOTO 9999
7186 C            IF (IDR1.NE.0) THEN
7187 C               CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7188 C     &                     AMCH1,AMCH1N,AMCH2,IREJ1)
7189 C               IF (IREJ1.NE.0) GOTO 9999
7190 C            ENDIF
7191 C* check second chain for resonance
7192 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7193 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
7194 C            IF (IREJ1.NE.0) GOTO 9999
7195 C            IF (IDR2.NE.0) IDR2 = 100*IDR2
7196 C         ENDIF
7197 C      ENDIF
7198
7199       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7200 * check chains for resonances
7201          CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7202      &               AMCH1,AMCH1N,IDCH1,IREJ1)
7203          IF (IREJ1.NE.0) GOTO 9999
7204          CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7205      &               AMCH2,AMCH2N,IDCH2,IREJ1)
7206          IF (IREJ1.NE.0) GOTO 9999
7207 * change kinematics corresponding to resonance-masses
7208          IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
7209             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7210      &                                 AMCH1,AMCH1N,AMCH2,IREJ1)
7211             IF (IREJ1.GT.0) GOTO 9999
7212             IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7213             CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7214      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
7215             IF (IREJ1.NE.0) GOTO 9999
7216             IF (IDR2.NE.0) IDR2 = 100*IDR2
7217          ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
7218             CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7219      &                                 AMCH2,AMCH2N,AMCH1,IREJ1)
7220             IF (IREJ1.GT.0) GOTO 9999
7221             IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7222             CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7223      &                  AMCH1,AMCH1N,IDCH1,IREJ1)
7224             IF (IREJ1.NE.0) GOTO 9999
7225             IF (IDR1.NE.0) IDR1 = 100*IDR1
7226          ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
7227             AMDIF1 = ABS(AMCH1-AMCH1N)
7228             AMDIF2 = ABS(AMCH2-AMCH2N)
7229             IF (AMDIF2.LT.AMDIF1) THEN
7230                CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7231      &                                    AMCH2,AMCH2N,AMCH1,IREJ1)
7232                IF (IREJ1.GT.0) GOTO 9999
7233                IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7234                CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
7235      &                     IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
7236                IF (IREJ1.NE.0) GOTO 9999
7237                IF (IDR1.NE.0) IDR1 = 100*IDR1
7238             ELSE
7239                CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7240      &                                    AMCH1,AMCH1N,AMCH2,IREJ1)
7241                IF (IREJ1.GT.0) GOTO 9999
7242                IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7243                CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
7244      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
7245                IF (IREJ1.NE.0) GOTO 9999
7246                IF (IDR2.NE.0) IDR2 = 100*IDR2
7247             ENDIF
7248          ENDIF
7249       ENDIF
7250
7251 * store final configuration for energy-momentum cons. check
7252       IF (LEMCCK) THEN
7253          CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
7254          CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
7255          IF (IREJ1.NE.0) GOTO 9999
7256       ENDIF
7257
7258 * put partons and chains into DTEVT1
7259       DO 10 I=1,4
7260          PCH1(I) = PP1(I)+PT1(I)
7261          PCH2(I) = PP2(I)+PT2(I)
7262    10 CONTINUE
7263       CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
7264      &                                      PP1(3),PP1(4),0,0,0)
7265       CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
7266      &                                      PT1(3),PT1(4),0,0,0)
7267       KCH = 100+IDCH(MOP1)*10+1
7268       CALL DT_EVTPUT(KCH,88888,-2,-1,
7269      &           PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
7270       CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
7271      &                                      PP2(3),PP2(4),0,0,0)
7272       CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
7273      &                                      PT2(3),PT2(4),0,0,0)
7274       KCH = KCH+1
7275       CALL DT_EVTPUT(KCH,88888,-2,-1,
7276      &           PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
7277
7278       RETURN
7279
7280  9999 CONTINUE
7281       IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
7282 * "cancel" sea-sea chains
7283          CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
7284          IF (IREJ1.NE.0) GOTO 9998
7285 **sr 16.5. flag for EVENTB
7286          IREJ = -1
7287          RETURN
7288       ENDIF
7289  9998 CONTINUE
7290       IREJ = 1
7291       RETURN
7292       END
7293
7294 *$ CREATE DT_CHKINE.FOR
7295 *COPY DT_CHKINE
7296 *
7297 *===chkine=============================================================*
7298 *
7299       SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
7300      &                  AMCH1,AMCH1N,AMCH2,IREJ)
7301
7302 ************************************************************************
7303 * This subroutine replaces CORMOM.                                     *
7304 * This version dated 05.01.95 is written by S. Roesler                 *
7305 ************************************************************************
7306
7307       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7308       SAVE
7309
7310       PARAMETER ( LINP = 10 ,
7311      &            LOUT = 6 ,
7312      &            LDAT = 9 )
7313
7314       PARAMETER (TINY10=1.0D-10)
7315
7316 * flags for input different options
7317       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7318       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7319      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7320
7321 * rejection counter
7322       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7323      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7324      &                IREXCI(3),IRDIFF(2),IRINC
7325
7326       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
7327      &          PP1I(4),PP2I(4),PT1I(4),PT2I(4)
7328
7329       IREJ  = 0
7330       JMSHL = IMSHL
7331
7332       SCALE  = AMCH1N/MAX(AMCH1,TINY10)
7333       DO 10 I=1,4
7334          PP1(I) = PP1I(I)
7335          PP2(I) = PP2I(I)
7336          PT1(I) = PT1I(I)
7337          PT2(I) = PT2I(I)
7338          PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
7339          PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
7340          PP1(I) = SCALE*PP1(I)
7341          PT1(I) = SCALE*PT1(I)
7342    10 CONTINUE
7343       IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
7344      &    (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
7345
7346       ECH = PP2(4)+PT2(4)
7347       PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
7348      &                               (PP2(3)+PT2(3))**2 )
7349       AMCH22 = (ECH-PCH)*(ECH+PCH)
7350       IF (AMCH22.LT.0.0D0) THEN
7351          IF (IOULEV(1).GT.0)
7352      &      WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
7353          GOTO 9997
7354       ENDIF
7355
7356       AMCH1 = AMCH1N
7357       AMCH2 = SQRT(AMCH22)
7358
7359 * put partons again on mass shell
7360    13 CONTINUE
7361       XM1 = 0.0D0
7362       XM2 = 0.0D0
7363       IF (JMSHL.EQ.1) THEN
7364
7365          XM1 = PYMASS(IFP1)
7366          XM2 = PYMASS(IFT1)
7367
7368       ENDIF
7369       CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
7370       IF (IREJ1.NE.0) THEN
7371          IF (JMSHL.EQ.0) GOTO 9998
7372          JMSHL = 0
7373          GOTO 13
7374       ENDIF
7375       JMSHL = IMSHL
7376       DO 11 I=1,4
7377          PP1(I) = P1(I)
7378          PT1(I) = P2(I)
7379    11 CONTINUE
7380    14 CONTINUE
7381       XM1 = 0.0D0
7382       XM2 = 0.0D0
7383       IF (JMSHL.EQ.1) THEN
7384
7385          XM1 = PYMASS(IFP2)
7386          XM2 = PYMASS(IFT2)
7387
7388       ENDIF
7389       CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
7390       IF (IREJ1.NE.0) THEN
7391          IF (JMSHL.EQ.0) GOTO 9998
7392          JMSHL = 0
7393          GOTO 14
7394       ENDIF
7395       DO 12 I=1,4
7396          PP2(I) = P1(I)
7397          PT2(I) = P2(I)
7398    12 CONTINUE
7399       DO 15 I=1,4
7400          PP1I(I) = PP1(I)
7401          PP2I(I) = PP2(I)
7402          PT1I(I) = PT1(I)
7403          PT2I(I) = PT2(I)
7404    15 CONTINUE
7405       RETURN
7406
7407  9997 IRCHKI(1) = IRCHKI(1)+1
7408 **sr
7409 C     GOTO 9999
7410       IREJ = -1
7411       RETURN
7412 **
7413  9998 IRCHKI(2) = IRCHKI(2)+1
7414
7415  9999 CONTINUE
7416       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7417       IREJ = 1
7418       RETURN
7419       END
7420
7421 *$ CREATE DT_CH2RES.FOR
7422 *COPY DT_CH2RES
7423 *
7424 *===ch2res=============================================================*
7425 *
7426       SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7427      &                  AM,AMN,IMODE,IREJ)
7428
7429 ************************************************************************
7430 * Check chains for resonance production.                               *
7431 * This subroutine replaces COMCMA/COBCMA/COMCM2                        *
7432 *    input:                                                            *
7433 *          IF1,2,3,4    input flavors (q,aq in any order)              *
7434 *          AM           chain mass                                     *
7435 *          MODE = 1     check q-aq chain for meson-resonance           *
7436 *               = 2     check q-qq, aq-aqaq chain for baryon-resonance *
7437 *               = 3     check qq-aqaq chain for lower mass cut         *
7438 *    output:                                                           *
7439 *          IDR = 0      no resonances found                            *
7440 *              = -1     pseudoscalar meson/octet baryon                *
7441 *              = 1      vector-meson/decuplet baryon                   *
7442 *          IDXR         BAMJET-index of corresponding resonance        *
7443 *          AMN          mass of corresponding resonance                *
7444 *                                                                      *
7445 *          IREJ         rejection flag                                 *
7446 * This version dated 06.01.95 is written by S. Roesler                 *
7447 ************************************************************************
7448
7449       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7450       SAVE
7451
7452       PARAMETER ( LINP = 10 ,
7453      &            LOUT = 6 ,
7454      &            LDAT = 9 )
7455
7456 * particle properties (BAMJET index convention)
7457       CHARACTER*8  ANAME
7458       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7459      &                IICH(210),IIBAR(210),K1(210),K2(210)
7460
7461 * quark-content to particle index conversion (DTUNUC 1.x)
7462       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7463      &                IA08(6,21),IA10(6,21)
7464
7465 * rejection counter
7466       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7467      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7468      &                IREXCI(3),IRDIFF(2),IRINC
7469
7470 * flags for input different options
7471       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7472       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7473      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7474
7475       DIMENSION IF(4),JF(4)
7476
7477 **sr 4.7. test
7478 C     DATA AMLOM,AMLOB /0.08D0,0.2D0/
7479       DATA AMLOM,AMLOB /0.1D0,0.7D0/
7480 **
7481 C     DATA AMLOM,AMLOB /0.001D0,0.001D0/
7482
7483       MODE = ABS(IMODE)
7484
7485       IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7486          WRITE(LOUT,1000) MODE
7487  1000    FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7488      &          1X,'        program stopped')
7489          STOP
7490       ENDIF
7491
7492       AMX  = AM
7493       IREJ = 0
7494       IDR  = 0
7495       IDXR = 0
7496       AMN  = AMX
7497       IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7498       IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7499
7500       IF(1) = IF1
7501       IF(2) = IF2
7502       IF(3) = IF3
7503       IF(4) = IF4
7504       NF = 0
7505       DO 100 I=1,4
7506          IF (IF(I).NE.0) THEN
7507             NF = NF+1
7508             JF(NF) = IF(I)
7509          ENDIF
7510   100 CONTINUE
7511       IF (NF.LE.MODE) THEN
7512          WRITE(LOUT,1001) MODE,IF
7513  1001    FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7514      &   I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7515          GOTO 9999
7516       ENDIF
7517
7518       GOTO (1,2,3) MODE
7519
7520 * check for meson resonance
7521     1 CONTINUE
7522       IFQ  = JF(1)
7523       IFAQ = ABS(JF(2))
7524       IF (JF(2).GT.0) THEN
7525          IFQ  = JF(2)
7526          IFAQ = ABS(JF(1))
7527       ENDIF
7528       IFPS = IMPS(IFAQ,IFQ)
7529       IFV  = IMVE(IFAQ,IFQ)
7530       AMPS = AAM(IFPS)
7531       AMV  = AAM(IFV)
7532       AMHI = AMV+0.3D0
7533       IF (AMX.LT.AMV) THEN
7534          IF (AMX.LT.AMPS) THEN
7535             IF (IMODE.GT.0) THEN
7536                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7537             ELSE
7538                IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7539             ENDIF
7540             LOMRES = LOMRES+1
7541          ENDIF
7542 *    replace chain by pseudoscalar meson
7543          IDR  = -1
7544          IDXR = IFPS
7545          AMN  = AMPS
7546       ELSEIF (AMX.LT.AMHI) THEN
7547 *    replace chain by vector-meson
7548          IDR  = 1
7549          IDXR = IFV
7550          AMN  = AMV
7551       ENDIF
7552       RETURN
7553
7554 * check for baryon resonance
7555     2 CONTINUE
7556       CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7557       AM8  = AAM(JB8)
7558       AM10 = AAM(JB10)
7559       AMHI = AM10+0.3D0
7560       IF (AMX.LT.AM10) THEN
7561          IF (AMX.LT.AM8) THEN
7562             IF (IMODE.GT.0) THEN
7563                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7564             ELSE
7565                IF (AMX.LT.0.8D0*AM8) GOTO 9999
7566             ENDIF
7567             LOBRES = LOBRES+1
7568          ENDIF
7569 *    replace chain by oktet baryon
7570          IDR  = -1
7571          IDXR = JB8
7572          AMN  = AM8
7573       ELSEIF (AMX.LT.AMHI) THEN
7574          IDR  = 1
7575          IDXR = JB10
7576          AMN  = AM10
7577       ENDIF
7578       RETURN
7579
7580 * check qq-aqaq for lower mass cut
7581     3 CONTINUE
7582 *   empirical definition of AMHI to allow for (b-antib)-pair prod.
7583       AMHI = 2.5D0
7584       IF (AMX.LT.AMHI) GOTO 9999
7585       RETURN
7586
7587  9999 CONTINUE
7588       IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7589      &    WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7590       IREJ = 1
7591       IRRES(2) = IRRES(2)+1
7592       RETURN
7593       END
7594
7595 *$ CREATE DT_RJSEAC.FOR
7596 *COPY DT_RJSEAC
7597 *
7598 *===rjseac=============================================================*
7599 *
7600       SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7601
7602 ************************************************************************
7603 * ReJection of SEA-sea Chains.                                         *
7604 *         MOP1/2       entries of projectile sea-partons in DTEVT1     *
7605 *         MOT1/2       entries of projectile sea-partons in DTEVT1     *
7606 * This version dated 16.01.95 is written by S. Roesler                 *
7607 ************************************************************************
7608
7609       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7610       SAVE
7611
7612       PARAMETER ( LINP = 10 ,
7613      &            LOUT = 6 ,
7614      &            LDAT = 9 )
7615
7616       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7617
7618 * event history
7619
7620       PARAMETER (NMXHKK=200000)
7621
7622       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7623      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7624      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7625
7626 * extended event history
7627       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7628      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7629      &                IHIST(2,NMXHKK)
7630
7631 * statistics
7632       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7633      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7634      &                ICEVTG(8,0:30)
7635
7636       DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7637
7638       IREJ = 0
7639
7640 * projectile sea q-aq-pair
7641 *    indices of sea-pair
7642       IDXSEA(1,1) = MOP1
7643       IDXSEA(1,2) = MOP2
7644 *    index of mother-nucleon
7645       IDXNUC(1)   = JMOHKK(1,MOP1)
7646 *    status of valence quarks to be corrected
7647       ISTVAL(1)   = -21
7648
7649 * target sea q-aq-pair
7650 *    indices of sea-pair
7651       IDXSEA(2,1) = MOT1
7652       IDXSEA(2,2) = MOT2
7653 *    index of mother-nucleon
7654       IDXNUC(2)   = JMOHKK(1,MOT1)
7655 *    status of valence quarks to be corrected
7656       ISTVAL(2)   = -22
7657
7658       DO 1 N=1,2
7659          IDONE = 0
7660          DO 2 I=NPOINT(2),NHKK
7661             IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7662      &          (JMOHKK(1,I).EQ.IDXNUC(N)))   THEN
7663 * valence parton found
7664 *    inrease 4-momentum by sea 4-momentum
7665                DO 3 K=1,4
7666                   PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7667      &                                  PHKK(K,IDXSEA(N,2))
7668     3          CONTINUE
7669                PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7670      &                              PHKK(2,I)**2-PHKK(3,I)**2))
7671 *    "cancel" sea-pair
7672                DO 4 J=1,2
7673                   ISTHKK(IDXSEA(N,J))   = 100
7674                   IDHKK(IDXSEA(N,J))    = 0
7675                   JMOHKK(1,IDXSEA(N,J)) = 0
7676                   JMOHKK(2,IDXSEA(N,J)) = 0
7677                   JDAHKK(1,IDXSEA(N,J)) = 0
7678                   JDAHKK(2,IDXSEA(N,J)) = 0
7679                   DO 5 K=1,4
7680                      PHKK(K,IDXSEA(N,J)) = ZERO
7681                      VHKK(K,IDXSEA(N,J)) = ZERO
7682                      WHKK(K,IDXSEA(N,J)) = ZERO
7683     5             CONTINUE
7684                   PHKK(5,IDXSEA(N,J)) = ZERO
7685     4          CONTINUE
7686                IDONE = 1
7687             ENDIF
7688     2    CONTINUE
7689          IF (IDONE.NE.1) THEN
7690             WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7691  1000       FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7692      &                '-record!',/,1X,'        sea-quark pairs   ',
7693      &                2I5,4X,2I5,'   could not be canceled!')
7694             GOTO 9999
7695          ENDIF
7696     1 CONTINUE
7697       ICRJSS = ICRJSS+1
7698       RETURN
7699
7700  9999 CONTINUE
7701       IREJ = 1
7702       RETURN
7703       END
7704
7705 *$ CREATE DT_VV2SCH.FOR
7706 *COPY DT_VV2SCH
7707 *
7708 *===vv2sch=============================================================*
7709 *
7710       SUBROUTINE DT_VV2SCH
7711
7712 ************************************************************************
7713 * Change Valence-Valence chain systems to Single CHain systems for     *
7714 * hadron-nucleus collisions with meson or antibaryon projectile.       *
7715 * (Reggeon contribution)                                               *
7716 * The single chain system is approximately treated as one chain and a  *
7717 * meson at rest.                                                       *
7718 * This version dated 18.01.95 is written by S. Roesler                 *
7719 ************************************************************************
7720
7721       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7722       SAVE
7723
7724       PARAMETER ( LINP = 10 ,
7725      &            LOUT = 6 ,
7726      &            LDAT = 9 )
7727
7728       PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7729
7730       LOGICAL LSTART
7731
7732 * event history
7733
7734       PARAMETER (NMXHKK=200000)
7735
7736       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7737      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7738      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7739
7740 * extended event history
7741       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7742      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7743      &                IHIST(2,NMXHKK)
7744
7745 * flags for input different options
7746       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7747       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7748      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7749
7750 * statistics
7751       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7752      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7753      &                ICEVTG(8,0:30)
7754
7755       DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7756      &          PCH2(4)
7757
7758       DATA LSTART /.TRUE./
7759
7760       IFSC  = 0
7761       IF (LSTART) THEN
7762          WRITE(LOUT,1000)
7763  1000    FORMAT(/,1X,'VV2SCH:  Reggeon contribution to valance-',
7764      &          'valence chains treated')
7765          LSTART = .FALSE.
7766       ENDIF
7767
7768       NSTOP = NHKK
7769
7770 * get index of first chain
7771       DO 1 I=NPOINT(3),NHKK
7772          IF (IDHKK(I).EQ.88888) THEN
7773             NC = I
7774             GOTO 2
7775          ENDIF
7776     1 CONTINUE
7777
7778     2 CONTINUE
7779       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7780      &                        .AND.(NC.LT.NSTOP)) THEN
7781 * get valence-valence chains
7782          IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7783 *   get "mother"-hadron indices
7784             MO1   = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7785             MO2   = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7786             KPROJ = IDT_ICIHAD(IDHKK(MO1))
7787             KTARG = IDT_ICIHAD(IDHKK(MO2))
7788 *   Lab momentum of projectile hadron
7789             CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7790             PTOT  = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7791      &                                  PHKK(3,MO1)**2)
7792
7793             SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7794             IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7795                ICVV2S = ICVV2S+1
7796 *   single chain requested
7797 *      get flavors of chain-end partons
7798                MO(1) = JMOHKK(1,NC)
7799                MO(2) = JMOHKK(2,NC)
7800                MO(3) = JMOHKK(1,NC+3)
7801                MO(4) = JMOHKK(2,NC+3)
7802                DO 3 I=1,4
7803                   IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7804                   IF(I,2) = 0
7805                   IF (ABS(IDHKK(MO(I))).GE.1000)
7806      &               IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7807     3          CONTINUE
7808 *      which one is the q-aq chain?
7809 *        N1,N1+1 - DTEVT1-entries for q-aq system
7810 *        N2,N2+1 - DTEVT1-entries for the other chain
7811                IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7812                   K1 = 1
7813                   K2 = 3
7814                   N1 = NC-2
7815                   N2 = NC+1
7816                ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7817                   K1 = 3
7818                   K2 = 1
7819                   N1 = NC+1
7820                   N2 = NC-2
7821                ELSE
7822                   GOTO 10
7823                ENDIF
7824                DO 4 K=1,4
7825                   PP1(K) = PHKK(K,N1)
7826                   PT1(K) = PHKK(K,N1+1)
7827                   PP2(K) = PHKK(K,N2)
7828                   PT2(K) = PHKK(K,N2+1)
7829     4          CONTINUE
7830                AMCH1 = PHKK(5,N1+2)
7831                AMCH2 = PHKK(5,N2+2)
7832 *      get meson-identity corresponding to flavors of q-aq chain
7833                ITMP   = IRESRJ
7834                IRESRJ = 0
7835                CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7836      &                     ZERO,AMCH1N,1,IDUM)
7837                IRESRJ = ITMP
7838 *      change kinematics of chains
7839                CALL DT_CHKINE(PP1,IDHKK(N1),  PP2,IDHKK(N2),
7840      &                     PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7841      &                     AMCH1,AMCH1N,AMCH2,IREJ1)
7842                IF (IREJ1.NE.0) GOTO 10
7843 *      check second chain for resonance
7844                IDCHAI = 2
7845                IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7846                CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7847      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7848                IF (IREJ1.NE.0) GOTO 10
7849                IF (IDR2.NE.0) IDR2 = 100*IDR2
7850 *      add partons and chains to DTEVT1
7851                DO 5 K=1,4
7852                   PCH1(K) = PP1(K)+PT1(K)
7853                   PCH2(K) = PP2(K)+PT2(K)
7854     5          CONTINUE
7855                CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7856      &                                             PP1(3),PP1(4),0,0,0)
7857                CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7858      &                                      PT1(2),PT1(3),PT1(4),0,0,0)
7859                KCH = ISTHKK(N1+2)+100
7860                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7861      &                     PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7862                IDHKK(N1+2) = 22222
7863                CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7864      &                                             PP2(3),PP2(4),0,0,0)
7865                CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7866      &                                      PT2(2),PT2(3),PT2(4),0,0,0)
7867                KCH = ISTHKK(N2+2)+100
7868                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7869      &                     PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7870                IDHKK(N2+2) = 22222
7871             ENDIF
7872          ENDIF
7873       ELSE
7874          GOTO 11
7875       ENDIF
7876    10 CONTINUE
7877       NC = NC+6
7878       GOTO 2
7879
7880    11 CONTINUE
7881
7882       RETURN
7883       END
7884
7885 *$ CREATE DT_PHNSCH.FOR
7886 *COPY DT_PHNSCH
7887 *
7888 *=== phnsch ===========================================================*
7889 *
7890       DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7891
7892 *----------------------------------------------------------------------*
7893 *                                                                      *
7894 *     Probability for Hadron Nucleon Single CHain interactions:        *
7895 *                                                                      *
7896 *     Created on 30 december 1993  by    Alfredo Ferrari & Paola Sala  *
7897 *                                                   Infn - Milan       *
7898 *                                                                      *
7899 *     Last change on 04-jan-94     by    Alfredo Ferrari               *
7900 *                                                                      *
7901 *             modified by J.R.for use in DTUNUC  6.1.94                *
7902 *                                                                      *
7903 *     Input variables:                                                 *
7904 *                      Kp = hadron projectile index (Part numbering    *
7905 *                           scheme)                                    *
7906 *                   Ktarg = target nucleon index (1=proton, 8=neutron) *
7907 *                    Plab = projectile laboratory momentum (GeV/c)     *
7908 *     Output variable:                                                 *
7909 *                  Phnsch = probability per single chain (particle     *
7910 *                           exchange) interactions                     *
7911 *                                                                      *
7912 *----------------------------------------------------------------------*
7913
7914       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7915       SAVE
7916
7917       PARAMETER ( LUNOUT = 6  )
7918       PARAMETER ( LUNERR = 6  )
7919       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
7920       PARAMETER ( ZERZER = 0.D+00 )
7921       PARAMETER ( ONEONE = 1.D+00 )
7922       PARAMETER ( TWOTWO = 2.D+00 )
7923       PARAMETER ( FIVFIV = 5.D+00 )
7924       PARAMETER ( HLFHLF = 0.5D+00 )
7925
7926       PARAMETER ( NALLWP = 39   )
7927       PARAMETER ( IDMAXP = 210  )
7928
7929       DIMENSION ICHRGE(39),AM(39)
7930
7931 * particle properties (BAMJET index convention)
7932       CHARACTER*8  ANAME
7933       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7934      &                IICH(210),IIBAR(210),K1(210),K2(210)
7935
7936       DIMENSION KPTOIP(210)
7937
7938 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7939       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7940      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7941      &                IQTCHR(-6:6),MQUARK(3,39)
7942
7943       DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7944       DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7945       EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7946       EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7947       EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7948
7949 * Conversion from part to paprop numbering
7950       DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7951      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7952      & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7953
7954 *  1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7955       DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7956      &    2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7957 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7958       DATA  SGTCO1  /
7959 * 1st reaction: gamma p total
7960      &0.147 D+00, ZERZER  , ZERZER   , 0.0022D+00, -0.0170D+00,
7961 * 2nd reaction: gamma d total
7962      &0.300 D+00, ZERZER  , ZERZER   , 0.0095D+00, -0.057 D+00,
7963 * 3rd reaction: pi+ p total
7964      &16.4  D+00, 19.3D+00, -0.42D+00, 0.19  D+00, ZERZER     ,
7965 * 4th reaction: pi- p total
7966      &33.0  D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03  D+00,
7967 * 5th reaction: pi+/- d total
7968      &56.8  D+00, 42.2D+00, -1.45D+00, 0.65  D+00, -5.39  D+00,
7969 * 6th reaction: K+ p total
7970      &18.1  D+00, ZERZER  , ZERZER   , 0.26  D+00, -1.0   D+00,
7971 * 7th reaction: K+ n total
7972      &18.7  D+00, ZERZER  , ZERZER   , 0.21  D+00, -0.89  D+00,
7973 * 8th reaction: K+ d total
7974      &34.2  D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99  D+00,
7975 * 9th reaction: K- p total
7976      &32.1  D+00, ZERZER  , ZERZER   , 0.66  D+00, -5.6   D+00,
7977 * 10th reaction: K- n total
7978      &25.2  D+00, ZERZER  , ZERZER   , 0.38  D+00, -2.9   D+00/
7979 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7980       DATA  SGTCO2  /
7981 * 11th reaction: K- d total
7982      &57.6  D+00, ZERZER  , ZERZER   , 1.17  D+00, -9.5   D+00,
7983 * 12th reaction: p p total
7984      &48.0  D+00, ZERZER  , ZERZER   , 0.522 D+00, -4.51  D+00,
7985 * 13th reaction: p n total
7986      &47.30 D+00, ZERZER  , ZERZER   , 0.513 D+00, -4.27  D+00,
7987 * 14th reaction: p d total
7988      &91.3  D+00, ZERZER  , ZERZER   , 1.05  D+00, -8.8   D+00,
7989 * 15th reaction: pbar p total
7990      &38.4  D+00, 77.6D+00, -0.64D+00, 0.26  D+00, -1.2   D+00,
7991 * 16th reaction: pbar n total
7992      &ZERZER    ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7   D+00,
7993 * 17th reaction: pbar d total
7994      &112.  D+00, 125.D+00, -1.08D+00, 1.14  D+00, -12.4  D+00,
7995 * 18th reaction: Lamda p total
7996      &30.4  D+00, ZERZER  , ZERZER   , ZERZER    , 1.6    D+00/
7997 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
7998       DATA SGTCO3  /
7999 * 19th reaction: pi+ p elastic
8000      &ZERZER    , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER     ,
8001 * 20th reaction: pi- p elastic
8002      &1.76  D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER     ,
8003 * 21st reaction: K+ p elastic
8004      &5.0   D+00, 8.1 D+00, -1.8 D+00, 0.16  D+00, -1.3   D+00,
8005 * 22nd reaction: K- p elastic
8006      &7.3   D+00, ZERZER  , ZERZER   , 0.29  D+00, -2.40  D+00,
8007 * 23rd reaction: p p elastic
8008      &11.9  D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85  D+00,
8009 * 24th reaction: p d elastic
8010      &16.1  D+00, ZERZER  , ZERZER   , 0.32  D+00, -3.4   D+00,
8011 * 25th reaction: pbar p elastic
8012      &10.2  D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28  D+00,
8013 * 26th reaction: pbar p elastic bis
8014      &10.6  D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41  D+00,
8015 * 27th reaction: pbar n elastic
8016      &36.5  D+00, ZERZER  , ZERZER   , ZERZER    , -11.9  D+00,
8017 * 28th reaction: Lamda p elastic
8018      &12.3  D+00, ZERZER  , ZERZER   , ZERZER    , -2.4   D+00,
8019 * 29th reaction: K- p ela bis
8020      &7.24  D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35  D+00,
8021 * 30th reaction: pi- p cx
8022      &ZERZER    ,0.912D+00, -1.22D+00, ZERZER    , ZERZER     ,
8023 * 31st reaction: K- p cx
8024      &ZERZER    , 3.39D+00, -1.75D+00, ZERZER    , ZERZER     ,
8025 * 32nd reaction: K+ n cx
8026      &ZERZER    , 7.18D+00, -2.01D+00, ZERZER    , ZERZER     ,
8027 * 33rd reaction: pbar p cx
8028      &ZERZER    , 18.8D+00, -2.01D+00, ZERZER    , ZERZER     /
8029 *
8030 *  +-------------------------------------------------------------------*
8031          ICHRGE(KTARG)=IICH(KTARG)
8032          AM    (KTARG)=AAM (KTARG)
8033 *  |  Check for pi0 (d-dbar)
8034       IF ( KP .NE. 26 ) THEN
8035          IP  = KPTOIP (KP)
8036          IF(IP.EQ.0)IP=1
8037          ICHRGE(IP)=IICH(KP)
8038          AM    (IP)=AAM (KP)
8039 *  |
8040 *  +-------------------------------------------------------------------*
8041 *  |
8042       ELSE
8043          IP = 23
8044          ICHRGE(IP)=0
8045       END IF
8046 *  |
8047 *  +-------------------------------------------------------------------*
8048 *  +-------------------------------------------------------------------*
8049 *  |  No such interactions for baryon-baryon
8050       IF ( IIBAR (KP) .GT. 0 ) THEN
8051          DT_PHNSCH = ZERZER
8052          RETURN
8053 *  |
8054 *  +-------------------------------------------------------------------*
8055 *  |  No "annihilation" diagram possible for K+ p/n
8056       ELSE IF ( IP .EQ. 15 ) THEN
8057          DT_PHNSCH = ZERZER
8058          RETURN
8059 *  |
8060 *  +-------------------------------------------------------------------*
8061 *  |  No "annihilation" diagram possible for K0 p/n
8062       ELSE IF ( IP .EQ. 24 ) THEN
8063          DT_PHNSCH = ZERZER
8064          RETURN
8065 *  |
8066 *  +-------------------------------------------------------------------*
8067 *  |  No "annihilation" diagram possible for Omebar p/n
8068       ELSE IF ( IP .GE. 38 ) THEN
8069          DT_PHNSCH = ZERZER
8070          RETURN
8071       END IF
8072 *  |
8073 *  +-------------------------------------------------------------------*
8074 *  +-------------------------------------------------------------------*
8075 *  |  If the momentum is larger than 50 GeV/c, compute the single
8076 *  |  chain probability at 50 GeV/c and extrapolate to the present
8077 *  |  momentum according to 1/sqrt(s)
8078 *  |  sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
8079 *  |  P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
8080 *  |  sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
8081 *  |  sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
8082 *  |                        x sqrt(s/s(50))
8083 *  |  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8084       IF ( PLAB .GT. 50.D+00 ) THEN
8085          PLA    = 50.D+00
8086          AMPSQ  = AM (IP)**2
8087          AMTSQ  = AM (KTARG)**2
8088          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
8089          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8090          EPROJ  = SQRT ( PLA**2 + AMPSQ )
8091          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8092          UMORAT = SQRT ( UMOSQ / UMO50 )
8093 *  |
8094 *  +-------------------------------------------------------------------*
8095 *  |  P < 3 GeV/c
8096       ELSE IF ( PLAB .LT. 3.D+00 ) THEN
8097          PLA    = 3.D+00
8098          AMPSQ  = AM (IP)**2
8099          AMTSQ  = AM (KTARG)**2
8100          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
8101          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8102          EPROJ  = SQRT ( PLA**2 + AMPSQ )
8103          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8104          UMORAT = SQRT ( UMOSQ / UMO50 )
8105 *  |
8106 *  +-------------------------------------------------------------------*
8107 *  |  P < 50 GeV/c
8108       ELSE
8109          PLA    = PLAB
8110          UMORAT = ONEONE
8111       END IF
8112 *  |
8113 *  +-------------------------------------------------------------------*
8114       ALGPLA = LOG (PLA)
8115 *  +-------------------------------------------------------------------*
8116 *  |  Pions:
8117       IF ( IHLP (IP) .EQ. 2 ) THEN
8118          ACOF = SGTCOE (1,3)
8119          BCOF = SGTCOE (2,3)
8120          ENNE = SGTCOE (3,3)
8121          CCOF = SGTCOE (4,3)
8122          DCOF = SGTCOE (5,3)
8123 *  |  Compute the pi+ p total cross section:
8124          SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8125      &          + DCOF * ALGPLA
8126          ACOF = SGTCOE (1,19)
8127          BCOF = SGTCOE (2,19)
8128          ENNE = SGTCOE (3,19)
8129          CCOF = SGTCOE (4,19)
8130          DCOF = SGTCOE (5,19)
8131 *  |  Compute the pi+ p elastic cross section:
8132          SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8133      &          + DCOF * ALGPLA
8134 *  |  Compute the pi+ p inelastic cross section:
8135          SPPPIN = SPPPTT - SPPPEL
8136          ACOF = SGTCOE (1,4)
8137          BCOF = SGTCOE (2,4)
8138          ENNE = SGTCOE (3,4)
8139          CCOF = SGTCOE (4,4)
8140          DCOF = SGTCOE (5,4)
8141 *  |  Compute the pi- p total cross section:
8142          SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8143      &          + DCOF * ALGPLA
8144          ACOF = SGTCOE (1,20)
8145          BCOF = SGTCOE (2,20)
8146          ENNE = SGTCOE (3,20)
8147          CCOF = SGTCOE (4,20)
8148          DCOF = SGTCOE (5,20)
8149 *  |  Compute the pi- p elastic cross section:
8150          SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8151      &          + DCOF * ALGPLA
8152 *  |  Compute the pi- p inelastic cross section:
8153          SPMPIN = SPMPTT - SPMPEL
8154          SIGDIA = SPMPIN - SPPPIN
8155 *  |  +----------------------------------------------------------------*
8156 *  |  |  Charged pions: besides isospin consideration it is supposed
8157 *  |  |                 that (pi+ n)el is almost equal to (pi- p)el
8158 *  |  |                 and  (pi+ p)el "    "     "    "  (pi- n)el
8159 *  |  |                 and all are almost equal among each others
8160 *  |  |                 (reasonable above 5 GeV/c)
8161          IF ( ICHRGE (IP) .NE. 0 ) THEN
8162             KHELP = KTARG / 8
8163             JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
8164             ACOF = SGTCOE (1,JREAC)
8165             BCOF = SGTCOE (2,JREAC)
8166             ENNE = SGTCOE (3,JREAC)
8167             CCOF = SGTCOE (4,JREAC)
8168             DCOF = SGTCOE (5,JREAC)
8169 *  |  |  Compute the total cross section:
8170             SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8171      &             + DCOF * ALGPLA
8172             JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
8173             ACOF = SGTCOE (1,JREAC)
8174             BCOF = SGTCOE (2,JREAC)
8175             ENNE = SGTCOE (3,JREAC)
8176             CCOF = SGTCOE (4,JREAC)
8177             DCOF = SGTCOE (5,JREAC)
8178 *  |  |  Compute the elastic cross section:
8179             SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8180      &             + DCOF * ALGPLA
8181 *  |  |  Compute the inelastic cross section:
8182             SHNCIN = SHNCTT - SHNCEL
8183 *  |  |  Number of diagrams:
8184             NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
8185 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8186             IQFSC1 = 1 + IP - 13
8187             IQFSC2 = 0
8188             IQBSC1 = 1 + KHELP
8189             IQBSC2 = 1 + IP - 13
8190 *  |  |
8191 *  |  +----------------------------------------------------------------*
8192 *  |  |  pi0: besides isospin consideration it is supposed that the
8193 *  |  |       elastic cross section is not very different from
8194 *  |  |       pi+ p and/or pi- p (reasonable above 5 GeV/c)
8195          ELSE
8196             KHELP  = KTARG / 8
8197             K2HLP  = ( KP - 23 ) / 3
8198 *  |  |  Number of diagrams:
8199 *  |  |  For u ubar (k2hlp=0):
8200 *           NDIAGR = 2 - KHELP
8201 *  |  |  For d dbar (k2hlp=1):
8202 *           NDIAGR = 2 + KHELP - K2HLP
8203             NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
8204             SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
8205 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8206             IQFSC1 = 1 + K2HLP
8207             IQFSC2 = 0
8208             IQBSC1 = 1 + KHELP
8209             IQBSC2 = 2 - K2HLP
8210          END IF
8211 *  |  |
8212 *  |  +----------------------------------------------------------------*
8213 *  |                                                   end pi's
8214 *  +-------------------------------------------------------------------*
8215 *  |  Kaons:
8216       ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
8217          ACOF = SGTCOE (1,6)
8218          BCOF = SGTCOE (2,6)
8219          ENNE = SGTCOE (3,6)
8220          CCOF = SGTCOE (4,6)
8221          DCOF = SGTCOE (5,6)
8222 *  |  Compute the K+ p total cross section:
8223          SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8224      &          + DCOF * ALGPLA
8225          ACOF = SGTCOE (1,21)
8226          BCOF = SGTCOE (2,21)
8227          ENNE = SGTCOE (3,21)
8228          CCOF = SGTCOE (4,21)
8229          DCOF = SGTCOE (5,21)
8230 *  |  Compute the K+ p elastic cross section:
8231          SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8232      &          + DCOF * ALGPLA
8233 *  |  Compute the K+ p inelastic cross section:
8234          SKPPIN = SKPPTT - SKPPEL
8235          ACOF = SGTCOE (1,9)
8236          BCOF = SGTCOE (2,9)
8237          ENNE = SGTCOE (3,9)
8238          CCOF = SGTCOE (4,9)
8239          DCOF = SGTCOE (5,9)
8240 *  |  Compute the K- p total cross section:
8241          SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8242      &          + DCOF * ALGPLA
8243          ACOF = SGTCOE (1,22)
8244          BCOF = SGTCOE (2,22)
8245          ENNE = SGTCOE (3,22)
8246          CCOF = SGTCOE (4,22)
8247          DCOF = SGTCOE (5,22)
8248 *  |  Compute the K- p elastic cross section:
8249          SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8250      &          + DCOF * ALGPLA
8251 *  |  Compute the K- p inelastic cross section:
8252          SKMPIN = SKMPTT - SKMPEL
8253          SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
8254 *  |  +----------------------------------------------------------------*
8255 *  |  |  Charged Kaons: actually only K-
8256          IF ( ICHRGE (IP) .NE. 0 ) THEN
8257             KHELP = KTARG / 8
8258 *  |  |  +-------------------------------------------------------------*
8259 *  |  |  |  Proton target:
8260             IF ( KHELP .EQ. 0 ) THEN
8261                SHNCIN = SKMPIN
8262 *  |  |  |  Number of diagrams:
8263                NDIAGR = 2
8264 *  |  |  |
8265 *  |  |  +-------------------------------------------------------------*
8266 *  |  |  |  Neutron target: besides isospin consideration it is supposed
8267 *  |  |  |              that (K- n)el is almost equal to (K- p)el
8268 *  |  |  |              (reasonable above 5 GeV/c)
8269             ELSE
8270                ACOF = SGTCOE (1,10)
8271                BCOF = SGTCOE (2,10)
8272                ENNE = SGTCOE (3,10)
8273                CCOF = SGTCOE (4,10)
8274                DCOF = SGTCOE (5,10)
8275 *  |  |  |  Compute the total cross section:
8276                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8277      &                + DCOF * ALGPLA
8278 *  |  |  |  Compute the elastic cross section:
8279                SHNCEL = SKMPEL
8280 *  |  |  |  Compute the inelastic cross section:
8281                SHNCIN = SHNCTT - SHNCEL
8282 *  |  |  |  Number of diagrams:
8283                NDIAGR = 1
8284             END IF
8285 *  |  |  |
8286 *  |  |  +-------------------------------------------------------------*
8287 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8288             IQFSC1 = 3
8289             IQFSC2 = 0
8290             IQBSC1 = 1 + KHELP
8291             IQBSC2 = 2
8292 *  |  |
8293 *  |  +----------------------------------------------------------------*
8294 *  |  |  K0's: (actually only K0bar)
8295          ELSE
8296             KHELP  = KTARG / 8
8297 *  |  |  +-------------------------------------------------------------*
8298 *  |  |  |  Proton target: (K0bar p)in supposed to be given by
8299 *  |  |  |                 (K- p)in - Sig_diagr
8300             IF ( KHELP .EQ. 0 ) THEN
8301                SHNCIN = SKMPIN - SIGDIA
8302 *  |  |  |  Number of diagrams:
8303                NDIAGR = 1
8304 *  |  |  |
8305 *  |  |  +-------------------------------------------------------------*
8306 *  |  |  |  Neutron target: (K0bar n)in supposed to be given by
8307 *  |  |  |                 (K- n)in + Sig_diagr
8308 *  |  |  |              besides isospin consideration it is supposed
8309 *  |  |  |              that (K- n)el is almost equal to (K- p)el
8310 *  |  |  |              (reasonable above 5 GeV/c)
8311             ELSE
8312                ACOF = SGTCOE (1,10)
8313                BCOF = SGTCOE (2,10)
8314                ENNE = SGTCOE (3,10)
8315                CCOF = SGTCOE (4,10)
8316                DCOF = SGTCOE (5,10)
8317 *  |  |  |  Compute the total cross section:
8318                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8319      &                + DCOF * ALGPLA
8320 *  |  |  |  Compute the elastic cross section:
8321                SHNCEL = SKMPEL
8322 *  |  |  |  Compute the inelastic cross section:
8323                SHNCIN = SHNCTT - SHNCEL + SIGDIA
8324 *  |  |  |  Number of diagrams:
8325                NDIAGR = 2
8326             END IF
8327 *  |  |  |
8328 *  |  |  +-------------------------------------------------------------*
8329 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8330             IQFSC1 = 3
8331             IQFSC2 = 0
8332             IQBSC1 = 1
8333             IQBSC2 = 1 + KHELP
8334          END IF
8335 *  |  |
8336 *  |  +----------------------------------------------------------------*
8337 *  |                                                   end Kaon's
8338 *  +-------------------------------------------------------------------*
8339 *  |  Antinucleons:
8340       ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
8341 *  |  For momenta between 3 and 5 GeV/c the use of tabulated data
8342 *  |  should be implemented!
8343          ACOF = SGTCOE (1,15)
8344          BCOF = SGTCOE (2,15)
8345          ENNE = SGTCOE (3,15)
8346          CCOF = SGTCOE (4,15)
8347          DCOF = SGTCOE (5,15)
8348 *  |  Compute the pbar p total cross section:
8349          SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8350      &          + DCOF * ALGPLA
8351          IF ( PLA .LT. FIVFIV ) THEN
8352             JREAC = 26
8353          ELSE
8354             JREAC = 25
8355          END IF
8356          ACOF = SGTCOE (1,JREAC)
8357          BCOF = SGTCOE (2,JREAC)
8358          ENNE = SGTCOE (3,JREAC)
8359          CCOF = SGTCOE (4,JREAC)
8360          DCOF = SGTCOE (5,JREAC)
8361 *  |  Compute the pbar p elastic cross section:
8362          SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8363      &          + DCOF * ALGPLA
8364 *  |  Compute the pbar p inelastic cross section:
8365          SAPPIN = SAPPTT - SAPPEL
8366          ACOF = SGTCOE (1,12)
8367          BCOF = SGTCOE (2,12)
8368          ENNE = SGTCOE (3,12)
8369          CCOF = SGTCOE (4,12)
8370          DCOF = SGTCOE (5,12)
8371 *  |  Compute the p p total cross section:
8372          SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8373      &          + DCOF * ALGPLA
8374          ACOF = SGTCOE (1,23)
8375          BCOF = SGTCOE (2,23)
8376          ENNE = SGTCOE (3,23)
8377          CCOF = SGTCOE (4,23)
8378          DCOF = SGTCOE (5,23)
8379 *  |  Compute the p p elastic cross section:
8380          SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8381      &          + DCOF * ALGPLA
8382 *  |  Compute the K- p inelastic cross section:
8383          SPPINE = SPPTOT - SPPELA
8384          SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
8385          KHELP  = KTARG / 8
8386 *  |  +----------------------------------------------------------------*
8387 *  |  |  Pbar:
8388          IF ( ICHRGE (IP) .NE. 0 ) THEN
8389             NDIAGR = 5 - KHELP
8390 *  |  |  +-------------------------------------------------------------*
8391 *  |  |  |  Proton target:
8392             IF ( KHELP .EQ. 0 ) THEN
8393 *  |  |  |  Number of diagrams:
8394                SHNCIN = SAPPIN
8395                PUUBAR = 0.8D+00
8396 *  |  |  |
8397 *  |  |  +-------------------------------------------------------------*
8398 *  |  |  |  Neutron target: it is supposed that (ap n)el is almost equal
8399 *  |  |  |                  to (ap p)el (reasonable above 5 GeV/c)
8400             ELSE
8401                ACOF = SGTCOE (1,16)
8402                BCOF = SGTCOE (2,16)
8403                ENNE = SGTCOE (3,16)
8404                CCOF = SGTCOE (4,16)
8405                DCOF = SGTCOE (5,16)
8406 *  |  |  |  Compute the total cross section:
8407                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8408      &                + DCOF * ALGPLA
8409 *  |  |  |  Compute the elastic cross section:
8410                SHNCEL = SAPPEL
8411 *  |  |  |  Compute the inelastic cross section:
8412                SHNCIN = SHNCTT - SHNCEL
8413                PUUBAR = HLFHLF
8414             END IF
8415 *  |  |  |
8416 *  |  |  +-------------------------------------------------------------*
8417 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8418 *  |  |  there are different possibilities, make a random choiche:
8419             IQFSC1 = -1
8420             RNCHEN = DT_RNDM(PUUBAR)
8421             IF ( RNCHEN .LT. PUUBAR ) THEN
8422                IQFSC2 = -2
8423             ELSE
8424                IQFSC2 = -1
8425             END IF
8426             IQBSC1 = -IQFSC1 + KHELP
8427             IQBSC2 = -IQFSC2
8428 *  |  |
8429 *  |  +----------------------------------------------------------------*
8430 *  |  |  nbar:
8431          ELSE
8432             NDIAGR = 4 + KHELP
8433 *  |  |  +-------------------------------------------------------------*
8434 *  |  |  |  Proton target: (nbar p)in supposed to be given by
8435 *  |  |  |                 (pbar p)in - Sig_diagr
8436             IF ( KHELP .EQ. 0 ) THEN
8437                SHNCIN = SAPPIN - SIGDIA
8438                PDDBAR = HLFHLF
8439 *  |  |  |
8440 *  |  |  +-------------------------------------------------------------*
8441 *  |  |  |  Neutron target: (nbar n)el is supposed to be equal to
8442 *  |  |  |                  (pbar p)el (reasonable above 5 GeV/c)
8443             ELSE
8444 *  |  |  |  Compute the total cross section:
8445                SHNCTT = SAPPTT
8446 *  |  |  |  Compute the elastic cross section:
8447                SHNCEL = SAPPEL
8448 *  |  |  |  Compute the inelastic cross section:
8449                SHNCIN = SHNCTT - SHNCEL
8450                PDDBAR = 0.8D+00
8451             END IF
8452 *  |  |  |
8453 *  |  |  +-------------------------------------------------------------*
8454 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8455 *  |  |  there are different possibilities, make a random choiche:
8456             IQFSC1 = -2
8457             RNCHEN = DT_RNDM(RNCHEN)
8458             IF ( RNCHEN .LT. PDDBAR ) THEN
8459                IQFSC2 = -1
8460             ELSE
8461                IQFSC2 = -2
8462             END IF
8463             IQBSC1 = -IQFSC1 + KHELP - 1
8464             IQBSC2 = -IQFSC2
8465          END IF
8466 *  |  |
8467 *  |  +----------------------------------------------------------------*
8468 *  |
8469 *  +-------------------------------------------------------------------*
8470 *  |  Others: not yet implemented
8471       ELSE
8472          SIGDIA = ZERZER
8473          SHNCIN = ONEONE
8474          NDIAGR = 0
8475          DT_PHNSCH = ZERZER
8476          RETURN
8477       END IF
8478 *  |                                                   end others
8479 *  +-------------------------------------------------------------------*
8480       DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8481       IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8482      &       + IQECHR (IQBSC2)
8483       IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8484      &       + IQBCHR (IQBSC2)
8485       IQECHC = IQECHC / 3
8486       IQBCHC = IQBCHC / 3
8487       IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8488      &       + IQSCHR (IQBSC2)
8489       IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8490      &       + IQSCHR (MQUARK(3,IP))
8491 *  +-------------------------------------------------------------------*
8492 *  |  Consistency check:
8493       IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8494          WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8495      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8496          WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8497      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8498          DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8499          DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8500       END IF
8501 *  |
8502 *  +-------------------------------------------------------------------*
8503 *  +-------------------------------------------------------------------*
8504 *  |  Consistency check:
8505       IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8506      &     .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8507          WRITE (LUNOUT,*)
8508      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8509      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8510          WRITE (LUNERR,*)
8511      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8512      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8513       END IF
8514 *  |
8515 *  +-------------------------------------------------------------------*
8516 *  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8517       IF ( UMORAT .GT. ONEPLS )
8518      &   DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8519      &                                 - ONEONE ) * UMORAT + ONEONE )
8520       RETURN
8521 *
8522       ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8523       DT_SCHQUA = ONEONE
8524       JQFSC1 = IQFSC1
8525       JQFSC2 = IQFSC2
8526       JQBSC1 = IQBSC1
8527       JQBSC2 = IQBSC2
8528 *=== End of function Phnsch ===========================================*
8529       RETURN
8530       END
8531
8532 *$ CREATE DT_RESPT.FOR
8533 *COPY DT_RESPT
8534 *
8535 *===respt==============================================================*
8536 *
8537       SUBROUTINE DT_RESPT
8538
8539 ************************************************************************
8540 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t.     *
8541 * This version dated 18.01.95 is written by S. Roesler                 *
8542 ************************************************************************
8543
8544       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8545       SAVE
8546
8547       PARAMETER ( LINP = 10 ,
8548      &            LOUT = 6 ,
8549      &            LDAT = 9 )
8550
8551       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8552
8553 * event history
8554
8555       PARAMETER (NMXHKK=200000)
8556
8557       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8558      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8559      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8560
8561 * extended event history
8562       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8563      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8564      &                IHIST(2,NMXHKK)
8565
8566 * get index of first chain
8567       DO 1 I=NPOINT(3),NHKK
8568          IF (IDHKK(I).EQ.88888) THEN
8569             NC = I
8570             GOTO 2
8571          ENDIF
8572     1 CONTINUE
8573
8574     2 CONTINUE
8575       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8576 C        WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8577 * skip VV-,SS- systems
8578          IF ((IDCH(NC  ).NE.1).AND.(IDCH(NC  ).NE.8).AND.
8579      &       (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8580 * check if both "chains" are resonances
8581             IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8582                CALL DT_SAPTRE(NC,NC+3)
8583             ENDIF
8584          ENDIF
8585       ELSE
8586          GOTO 3
8587       ENDIF
8588       NC = NC+6
8589       GOTO 2
8590
8591     3 CONTINUE
8592
8593       RETURN
8594       END
8595
8596 *$ CREATE DT_EVTRES.FOR
8597 *COPY DT_EVTRES
8598 *
8599 *===evtres=============================================================*
8600 *
8601       SUBROUTINE DT_EVTRES(IREJ)
8602
8603 ************************************************************************
8604 * This version dated 14.12.94 is written by S. Roesler                 *
8605 ************************************************************************
8606
8607       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8608       SAVE
8609
8610       PARAMETER ( LINP = 10 ,
8611      &            LOUT = 6 ,
8612      &            LDAT = 9 )
8613
8614       PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8615
8616 * event history
8617
8618       PARAMETER (NMXHKK=200000)
8619
8620       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8621      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8622      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8623
8624 * extended event history
8625       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8626      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8627      &                IHIST(2,NMXHKK)
8628
8629 * flags for input different options
8630       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8631       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8632      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8633
8634 * particle properties (BAMJET index convention)
8635       CHARACTER*8  ANAME
8636       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8637      &                IICH(210),IIBAR(210),K1(210),K2(210)
8638
8639       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8640
8641       IREJ = 0
8642
8643       DO 1 I=NPOINT(3),NHKK
8644          IF (ABS(IDRES(I)).GE.100) THEN
8645             AMMX = 0.0D0
8646             DO 2 J=NPOINT(3),NHKK
8647                IF (IDHKK(J).EQ.88888) THEN
8648                   IF (PHKK(5,J).GT.AMMX) THEN
8649                      AMMX = PHKK(5,J)
8650                      IMMX = J
8651                   ENDIF
8652                ENDIF
8653     2       CONTINUE
8654             IF (IDRES(IMMX).NE.0) THEN
8655                IF (IOULEV(3).GT.0) THEN
8656                   WRITE(LOUT,'(1X,A)')
8657      &               'EVTRES: no chain for correc. found'
8658 C                 GOTO 6
8659                   GOTO 9999
8660                ELSE
8661                   GOTO 9999
8662                ENDIF
8663             ENDIF
8664             IMO11  = JMOHKK(1,I)
8665             IMO12  = JMOHKK(2,I)
8666             IF (PHKK(3,IMO11).LT.0.0D0) THEN
8667                IMO11 = JMOHKK(2,I)
8668                IMO12 = JMOHKK(1,I)
8669             ENDIF
8670             IMO21  = JMOHKK(1,IMMX)
8671             IMO22  = JMOHKK(2,IMMX)
8672             IF (PHKK(3,IMO21).LT.0.0D0) THEN
8673                IMO21 = JMOHKK(2,IMMX)
8674                IMO22 = JMOHKK(1,IMMX)
8675             ENDIF
8676             AMCH1  = PHKK(5,I)
8677             AMCH1N = AAM(IDXRES(I))
8678
8679             IFPR1 = IDHKK(IMO11)
8680             IFPR2 = IDHKK(IMO21)
8681             IFTA1 = IDHKK(IMO12)
8682             IFTA2 = IDHKK(IMO22)
8683             DO 4 J=1,4
8684                PP1(J) = PHKK(J,IMO11)
8685                PP2(J) = PHKK(J,IMO21)
8686                PT1(J) = PHKK(J,IMO12)
8687                PT2(J) = PHKK(J,IMO22)
8688     4       CONTINUE
8689 * store initial configuration for energy-momentum cons. check
8690             IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8691 * correct kinematics of second chain
8692             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8693      &                  AMCH1,AMCH1N,AMCH2,IREJ1)
8694             IF (IREJ1.NE.0) GOTO 9999
8695 * check now this chain for resonance mass
8696             IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8697             IFP(2) = 0
8698             IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8699             IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8700             IFT(2) = 0
8701             IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8702             IDCH2 = 2
8703             IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8704             IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8705             CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8706      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
8707             IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8708                IF (IOULEV(1).GT.0)
8709      &            WRITE(LOUT,*) ' correction for resonance not poss.'
8710 **sr test
8711 C              GOTO 1
8712 C              GOTO 9999
8713 **
8714             ENDIF
8715 * store final configuration for energy-momentum cons. check
8716             IF (LEMCCK) THEN
8717                CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8718                CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8719                IF (IREJ1.NE.0) GOTO 9999
8720             ENDIF
8721             DO 5 J=1,4
8722                PHKK(J,IMO11) = PP1(J)
8723                PHKK(J,IMO21) = PP2(J)
8724                PHKK(J,IMO12) = PT1(J)
8725                PHKK(J,IMO22) = PT2(J)
8726     5       CONTINUE
8727 * correct entries of chains
8728             DO 3 K=1,4
8729                PHKK(K,I)    = PHKK(K,IMO11)+PHKK(K,IMO12)
8730                PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8731     3       CONTINUE
8732             AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8733             AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8734      &            PHKK(3,IMMX)**2
8735 * ?? the following should now be obsolete
8736 **sr test
8737 C           IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8738             IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8739 **
8740                WRITE(LOUT,'(1X,A,4G10.3)')
8741      &          'EVTRES: inonsistent mass-corr.',AM1,AM2
8742 C              GOTO 9999
8743                GOTO 1
8744             ENDIF
8745             PHKK(5,I)    = SQRT(AM1)
8746             PHKK(5,IMMX) = SQRT(AM2)
8747             IDRES(I)     = IDRES(I)/100
8748             IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8749      &          (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8750                WRITE(LOUT,'(1X,A,4G10.3)')
8751      &          'EVTRES: inconsistent chain-masses',
8752      &          PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8753                GOTO 9999
8754             ENDIF
8755          ENDIF
8756     1 CONTINUE
8757     6 CONTINUE
8758       RETURN
8759
8760  9999 CONTINUE
8761       IREJ = 1
8762       RETURN
8763       END
8764
8765 *$ CREATE DT_GETSPT.FOR
8766 *COPY DT_GETSPT
8767 *
8768 *===getspt=============================================================*
8769 *
8770       SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8771      &                  PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8772      &                  AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8773
8774 ************************************************************************
8775 * This version dated 12.12.94 is written by S. Roesler                 *
8776 ************************************************************************
8777
8778       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8779       SAVE
8780
8781       PARAMETER ( LINP = 10 ,
8782      &            LOUT = 6 ,
8783      &            LDAT = 9 )
8784
8785       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8786
8787 * various options for treatment of partons (DTUNUC 1.x)
8788 * (chain recombination, Cronin,..)
8789       LOGICAL LCO2CR,LINTPT
8790       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8791      &                LCO2CR,LINTPT
8792
8793 * flags for input different options
8794       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8795       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8796      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8797
8798 * flags for diffractive interactions (DTUNUC 1.x)
8799       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8800
8801       DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8802      &          PT2(4),PT2I(4),P1(4),P2(4),
8803      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8804      &          PTOTI(4),PTOTF(4),DIFF(4)
8805
8806       IC   = 0
8807       IREJ = 0
8808 C     B33P = 4.0D0
8809 C     B33T = 4.0D0
8810 C     IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8811 C     IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8812       REDU = 1.0D0
8813 C     B33P = 3.5D0
8814 C     B33T = 3.5D0
8815       B33P = 4.0D0
8816       B33T = 4.0D0
8817       IF (IDIFF.NE.0) THEN
8818          B33P = 16.0D0
8819          B33T = 16.0D0
8820       ENDIF
8821
8822       DO 1 I=1,4
8823          PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8824          PP1(I)   = PP1I(I)
8825          PP2(I)   = PP2I(I)
8826          PT1(I)   = PT1I(I)
8827          PT2(I)   = PT2I(I)
8828     1 CONTINUE
8829 * get initial chain masses
8830       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8831      &                               +(PP1(3)+PT1(3))**2)
8832       ECH   = PP1(4)+PT1(4)
8833       AM1   = (ECH+PTOCH)*(ECH-PTOCH)
8834       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8835      &                               +(PP2(3)+PT2(3))**2)
8836       ECH   = PP2(4)+PT2(4)
8837       AM2   = (ECH+PTOCH)*(ECH-PTOCH)
8838       IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8839          IF (IOULEV(1).GT.0)
8840      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8841      &                              AM1,AM2
8842          GOTO 9999
8843       ENDIF
8844       AM1  = SQRT(AM1)
8845       AM2  = SQRT(AM2)
8846       AM1N = ZERO
8847       AM2N = ZERO
8848
8849       MODE = 0
8850 C      IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8851 C        MODE = 0
8852 C      ELSE
8853 C         MODE = 1
8854 C         IF (AM1.LT.0.6) THEN
8855 C            B33P = 10.0D0
8856 C         ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8857 CC           B33P = 4.0D0
8858 C         ENDIF
8859 C         IF (AM2.LT.0.6) THEN
8860 C            B33T = 10.0D0
8861 C         ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8862 CC           B33T = 4.0D0
8863 C         ENDIF
8864 C      ENDIF
8865
8866 * check chain masses for very low mass chains
8867 C     CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8868 C    &            AM1,DUM,-IDCH1,IREJ1)
8869 C     CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8870 C    &            AM2,DUM,-IDCH2,IREJ2)
8871 C     IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8872 C        B33P = 20.0D0
8873 C        B33T = 20.0D0
8874 C     ENDIF
8875
8876       JMSHL = IMSHL
8877
8878     2 CONTINUE
8879       IC = IC+1
8880       IF (MOD(IC,15).EQ.0) B33P  = 2.0D0*B33P
8881       IF (MOD(IC,15).EQ.0) B33T  = 2.0D0*B33T
8882       IF (MOD(IC,18).EQ.0) REDU  = 0.0D0
8883 C     IF (MOD(IC,19).EQ.0) JMSHL = 0
8884       IF (MOD(IC,20).EQ.0) GOTO 7
8885 C        WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8886 C        RETURN
8887 C        GOTO 9999
8888 C     ENDIF
8889
8890 * get transverse momentum
8891       IF (LINTPT) THEN
8892          ES   = -2.0D0/(B33P**2)
8893      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8894          HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8895          HPSP = HPSP*REDU
8896          ES   = -2.0D0/(B33T**2)
8897      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8898          HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8899          HPST = HPST*REDU
8900       ELSE
8901          HPSP = ZERO
8902          HPST = ZERO
8903       ENDIF
8904       CALL DT_DSFECF(SFE1,CFE1)
8905       CALL DT_DSFECF(SFE2,CFE2)
8906       IF (MODE.EQ.0) THEN
8907          PP1(1) = PP1I(1)+HPSP*CFE1
8908          PP1(2) = PP1I(2)+HPSP*SFE1
8909          PP2(1) = PP2I(1)-HPSP*CFE1
8910          PP2(2) = PP2I(2)-HPSP*SFE1
8911          PT1(1) = PT1I(1)+HPST*CFE2
8912          PT1(2) = PT1I(2)+HPST*SFE2
8913          PT2(1) = PT2I(1)-HPST*CFE2
8914          PT2(2) = PT2I(2)-HPST*SFE2
8915       ELSE
8916          PP1(1) = PP1I(1)+HPSP*CFE1
8917          PP1(2) = PP1I(2)+HPSP*SFE1
8918          PT1(1) = PT1I(1)-HPSP*CFE1
8919          PT1(2) = PT1I(2)-HPSP*SFE1
8920          PP2(1) = PP2I(1)+HPST*CFE2
8921          PP2(2) = PP2I(2)+HPST*SFE2
8922          PT2(1) = PT2I(1)-HPST*CFE2
8923          PT2(2) = PT2I(2)-HPST*SFE2
8924       ENDIF
8925
8926 * put partons on mass shell
8927       XMP1 = 0.0D0
8928       XMT1 = 0.0D0
8929       IF (JMSHL.EQ.1) THEN
8930
8931          XMP1 = PYMASS(IFPR1)
8932          XMT1 = PYMASS(IFTA1)
8933
8934       ENDIF
8935       CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8936       IF (IREJ1.NE.0) GOTO 2
8937       DO 3 I=1,4
8938          PTOTF(I) = P1(I)+P2(I)
8939          PP1(I)   = P1(I)
8940          PT1(I)   = P2(I)
8941     3 CONTINUE
8942       XMP2 = 0.0D0
8943       XMT2 = 0.0D0
8944       IF (JMSHL.EQ.1) THEN
8945
8946          XMP2 = PYMASS(IFPR2)
8947          XMT2 = PYMASS(IFTA2)
8948
8949       ENDIF
8950       CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8951       IF (IREJ1.NE.0) GOTO 2
8952       DO 4 I=1,4
8953          PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8954          PP2(I)   = P1(I)
8955          PT2(I)   = P2(I)
8956     4 CONTINUE
8957
8958 * check consistency
8959       DO 5 I=1,4
8960          DIFF(I) = PTOTI(I)-PTOTF(I)
8961     5 CONTINUE
8962       IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8963      &    (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8964          WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8965          GOTO 9999
8966       ENDIF
8967       PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8968       AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8969       PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8970       AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8971       PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8972       AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8973       PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8974       AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8975       IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8976      &    (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8977      &                                                           THEN
8978          WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8979      &     'GETSPT: inconsistent masses',
8980      &     AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8981 * sr 22.11.00: commented. It should only have inconsistent masses for
8982 * ultrahigh energies due to rounding problems
8983 C        GOTO 9999
8984       ENDIF
8985
8986 * get chain masses
8987       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8988      &                               +(PP1(3)+PT1(3))**2)
8989       ECH   = PP1(4)+PT1(4)
8990       AM1N  = (ECH+PTOCH)*(ECH-PTOCH)
8991       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8992      &                               +(PP2(3)+PT2(3))**2)
8993       ECH   = PP2(4)+PT2(4)
8994       AM2N  = (ECH+PTOCH)*(ECH-PTOCH)
8995       IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
8996          IF (IOULEV(1).GT.0)
8997      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
8998      &                              AM1N,AM2N
8999          GOTO 2
9000       ENDIF
9001       AM1N = SQRT(AM1N)
9002       AM2N = SQRT(AM2N)
9003
9004 * check chain masses for very low mass chains
9005       CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
9006      &            AM1N,DUM,-IDCH1,IREJ1)
9007       IF (IREJ1.NE.0) GOTO 2
9008       CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
9009      &            AM2N,DUM,-IDCH2,IREJ2)
9010       IF (IREJ2.NE.0) GOTO 2
9011
9012     7 CONTINUE
9013       IF (AM1N.GT.ZERO) THEN
9014          AM1 = AM1N
9015          AM2 = AM2N
9016       ENDIF
9017       DO 6 I=1,4
9018          PP1I(I)   = PP1(I)
9019          PP2I(I)   = PP2(I)
9020          PT1I(I)   = PT1(I)
9021          PT2I(I)   = PT2(I)
9022     6 CONTINUE
9023
9024       RETURN
9025
9026  9999 CONTINUE
9027       IREJ = 1
9028       RETURN
9029       END
9030
9031 *$ CREATE DT_SAPTRE.FOR
9032 *COPY DT_SAPTRE
9033 *
9034 *===saptre=============================================================*
9035 *
9036       SUBROUTINE DT_SAPTRE(IDX1,IDX2)
9037
9038 ************************************************************************
9039 * p-t sampling for two-resonance systems. ("BAMJET-like" method)       *
9040 *        IDX1,IDX2       indices of resonances ("chains") in DTEVT1    *
9041 * Adopted from the original SAPTRE written by J. Ranft.                *
9042 * This version dated 18.01.95 is written by S. Roesler                 *
9043 ************************************************************************
9044
9045       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9046       SAVE
9047
9048       PARAMETER ( LINP = 10 ,
9049      &            LOUT = 6 ,
9050      &            LDAT = 9 )
9051
9052       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
9053
9054 * event history
9055
9056       PARAMETER (NMXHKK=200000)
9057
9058       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9059      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9060      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9061
9062 * extended event history
9063       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9064      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9065      &                IHIST(2,NMXHKK)
9066
9067 * flags for input different options
9068       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9069       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9070      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9071
9072       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
9073
9074       DATA B3 /4.0D0/
9075
9076       ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
9077       ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
9078       ESMAX  = MIN(ESMAX1,ESMAX2)
9079       IF (ESMAX.LE.0.05D0) RETURN
9080
9081       HMA    = PHKK(5,IDX1)
9082       DO 1 K=1,4
9083          PA1(K) = PHKK(K,IDX1)
9084          PA2(K) = PHKK(K,IDX2)
9085     1 CONTINUE
9086
9087       IF (LEMCCK) THEN
9088          CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
9089          CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
9090       ENDIF
9091
9092       EXEB   = 0.0D0
9093       IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
9094       BEXP   = HMA*(1.0D0-EXEB)/B3
9095       AXEXP  = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
9096       WA     = AXEXP/(BEXP+AXEXP)
9097       XAB    = DT_RNDM(WA)
9098    10 CONTINUE
9099 * ES is the transverse kinetic energy
9100       IF (XAB.LT.WA)THEN
9101         X  = DT_RNDM(WA)
9102         Y  = DT_RNDM(WA)
9103         ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
9104       ELSE
9105         X  = DT_RNDM(Y)
9106         ES = ABS(-LOG(X+TINY7)/B3)
9107       ENDIF
9108       IF (ES.GT.ESMAX) GOTO 10
9109       ES  = ES+HMA
9110 * transverse momentum
9111       HPS = SQRT((ES-HMA)*(ES+HMA))
9112
9113       CALL DT_DSFECF(SFE,CFE)
9114       HPX = HPS*CFE
9115       HPY = HPS*SFE
9116       PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
9117       PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
9118       IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
9119
9120 C     PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
9121 C     PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
9122       PA1(1) = PA1(1)+HPX
9123       PA1(2) = PA1(2)+HPY
9124       PA2(1) = PA2(1)-HPX
9125       PA2(2) = PA2(2)-HPY
9126
9127 * put resonances on mass-shell again
9128       XM1 = PHKK(5,IDX1)
9129       XM2 = PHKK(5,IDX2)
9130       CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
9131       IF (IREJ1.NE.0) RETURN
9132
9133       IF (LEMCCK) THEN
9134          CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
9135          CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
9136          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
9137          IF (IREJ1.NE.0) RETURN
9138       ENDIF
9139
9140       DO 2 K=1,4
9141          PHKK(K,IDX1) = P1(K)
9142          PHKK(K,IDX2) = P2(K)
9143     2 CONTINUE
9144
9145       RETURN
9146       END
9147
9148 *$ CREATE DT_CRONIN.FOR
9149 *COPY DT_CRONIN
9150 *
9151 *===cronin=============================================================*
9152 *
9153       SUBROUTINE DT_CRONIN(INCL)
9154
9155 ************************************************************************
9156 * Cronin-Effect. Multiple scattering of partons at chain ends.         *
9157 *             INCL = 1     multiple sc. in projectile                  *
9158 *                  = 2     multiple sc. in target                      *
9159 * This version dated 05.01.96 is written by S. Roesler.                *
9160 ************************************************************************
9161
9162       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9163       SAVE
9164
9165       PARAMETER ( LINP = 10 ,
9166      &            LOUT = 6 ,
9167      &            LDAT = 9 )
9168
9169       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9170
9171 * event history
9172
9173       PARAMETER (NMXHKK=200000)
9174
9175       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9176      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9177      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9178
9179 * extended event history
9180       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9181      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9182      &                IHIST(2,NMXHKK)
9183
9184 * rejection counter
9185       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9186      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9187      &                IREXCI(3),IRDIFF(2),IRINC
9188
9189 * Glauber formalism: collision properties
9190       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9191      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
9192
9193       DIMENSION R(3),PIN(4),POUT(4),DEV(4)
9194
9195       DO 1 K=1,4
9196          DEV(K) = ZERO
9197     1 CONTINUE
9198
9199       DO 2 I=NPOINT(2),NHKK
9200          IF (ISTHKK(I).LT.0) THEN
9201 * get z-position of the chain
9202             R(1) = VHKK(1,I)*1.0D12
9203             IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
9204             R(2) = VHKK(2,I)*1.0D12
9205             IDXNU = JMOHKK(1,I)
9206             IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
9207      &                             IDXNU = JMOHKK(1,I-1)
9208             IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
9209      &                             IDXNU = JMOHKK(1,I+1)
9210             R(3) = VHKK(3,IDXNU)*1.0D12
9211 * position of target parton the chain is connected to
9212             DO 3 K=1,4
9213                PIN(K) = PHKK(K,I)
9214     3       CONTINUE
9215 * multiple scattering of parton with DTEVT1-index I
9216             CALL DT_CROMSC(PIN,R,POUT,INCL)
9217 **testprint
9218 C           IF (NEVHKK.EQ.5) THEN
9219 C              AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
9220 C              AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
9221 C              AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
9222 C              AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
9223 C              WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
9224 C              WRITE(6,'(A,4E15.5)')'PIN:       ',PIN
9225 C              WRITE(6,'(A,4E15.5)')'POUT:      ',POUT
9226 C           ENDIF
9227 **
9228 * increase accumulator by energy-momentum difference
9229             DO 4 K=1,4
9230                DEV(K)    = DEV(K)+POUT(K)-PIN(K)
9231                PHKK(K,I) = POUT(K)
9232     4       CONTINUE
9233             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9234      &                           PHKK(2,I)**2-PHKK(3,I)**2))
9235          ENDIF
9236     2 CONTINUE
9237
9238 * dump accumulator to momenta of valence partons
9239       NVAL = 0
9240       ETOT = 0.0D0
9241       DO 5 I=NPOINT(2),NHKK
9242          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9243             NVAL = NVAL+1
9244             ETOT = ETOT+PHKK(4,I)
9245          ENDIF
9246     5 CONTINUE
9247 C     WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
9248  1000 FORMAT(1X,'CRONIN :  number of val. partons ',I4,/,
9249      &       9X,4E12.4)
9250       DO 6 I=NPOINT(2),NHKK
9251          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9252             E = PHKK(4,I)
9253             DO 7 K=1,4
9254 C              PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
9255                PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
9256     7       CONTINUE
9257             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9258      &                           PHKK(2,I)**2-PHKK(3,I)**2))
9259          ENDIF
9260     6 CONTINUE
9261
9262       RETURN
9263       END
9264
9265 *$ CREATE DT_CROMSC.FOR
9266 *COPY DT_CROMSC
9267 *
9268 *===cromsc=============================================================*
9269 *
9270       SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
9271
9272 ************************************************************************
9273 * Cronin-Effect. Multiple scattering of one parton passing through     *
9274 * nuclear matter.                                                      *
9275 *            PIN(4)       input 4-momentum of parton                   *
9276 *            POUT(4)      4-momentum of parton after mult. scatt.      *
9277 *            R(3)         spatial position of parton in target nucleus *
9278 *            INCL = 1     multiple sc. in projectile                   *
9279 *                 = 2     multiple sc. in target                       *
9280 * This is a revised version of the original version written by J. Ranft*
9281 * This version dated 17.01.95 is written by S. Roesler.                *
9282 ************************************************************************
9283
9284       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9285       SAVE
9286
9287       PARAMETER ( LINP = 10 ,
9288      &            LOUT = 6 ,
9289      &            LDAT = 9 )
9290
9291       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9292
9293       LOGICAL LSTART
9294
9295 * rejection counter
9296       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9297      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9298      &                IREXCI(3),IRDIFF(2),IRINC
9299
9300 * Glauber formalism: collision properties
9301       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9302      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
9303
9304 * various options for treatment of partons (DTUNUC 1.x)
9305 * (chain recombination, Cronin,..)
9306       LOGICAL LCO2CR,LINTPT
9307       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9308      &                LCO2CR,LINTPT
9309
9310       DIMENSION PIN(4),POUT(4),R(3)
9311
9312       DATA LSTART /.TRUE./
9313
9314       IRCRON(1) = IRCRON(1)+1
9315
9316       IF (LSTART) THEN
9317          WRITE(LOUT,1000) CRONCO
9318  1000    FORMAT(/,1X,'CROMSC:  multiple scattering of chain ends',
9319      &          ' treated',/,10X,'with parameter CRONCO = ',F5.2)
9320          LSTART = .FALSE.
9321       ENDIF
9322
9323       NCBACK = 0
9324       RNCL   = RPROJ
9325       IF (INCL.EQ.2) RNCL = RTARG
9326
9327 * Lorentz-transformation into Lab.
9328       MODE = -(INCL+1)
9329       CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
9330
9331       PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
9332       IF (PTOT.LE.8.0D0) GOTO 9997
9333
9334 * direction cosines of parton before mult. scattering
9335       COSX = PIN(1)/PTOT
9336       COSY = PIN(2)/PTOT
9337       COSZ = PZ/PTOT
9338
9339       RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
9340       IF (RTESQ.GE.-TINY3) GOTO 9999
9341
9342 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
9343 * in the direction of particle motion
9344
9345       A    = COSX*R(1)+COSY*R(2)+COSZ*R(3)
9346       TMP  = A**2-RTESQ
9347       IF (TMP.LT.ZERO) GOTO 9998
9348       DIST = -A+SQRT(TMP)
9349
9350 * multiple scattering angle
9351       THETO = CRONCO*SQRT(DIST)/PTOT
9352       IF (THETO.GT.0.1D0) THETO=0.1D0
9353
9354     1 CONTINUE
9355 * Gaussian sampling of spatial angle
9356       CALL DT_RANNOR(R1,R2)
9357       THETA = ABS(R1*THETO)
9358       IF (THETA.GT.0.3D0) GOTO 9997
9359       CALL DT_DSFECF(SFE,CFE)
9360       COSTH = COS(THETA)
9361       SINTH = SIN(THETA)
9362
9363 * new direction cosines
9364       CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
9365      &                               COSXN,COSYN,COSZN)
9366
9367       POUT(1) = COSXN*PTOT
9368       POUT(2) = COSYN*PTOT
9369       PZ      = COSZN*PTOT
9370 * Lorentz-transformation into nucl.-nucl. cms
9371       MODE = INCL+1
9372       CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
9373
9374 C     IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
9375 C     IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
9376       IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
9377          THETO = THETO/2.0D0
9378          NCBACK = NCBACK+1
9379          IF (MOD(NCBACK,200).EQ.0) THEN
9380             WRITE(LOUT,1001) THETO,PIN,POUT
9381  1001       FORMAT(1X,'CROMSC: inconsistent scattering angle ',
9382      &             E12.4,/,1X,'        PIN :',4E12.4,/,
9383      &             1X,'       POUT:',4E12.4)
9384             GOTO 9997
9385          ENDIF
9386          GOTO 1
9387       ENDIF
9388
9389       RETURN
9390
9391  9997 IRCRON(2) = IRCRON(2)+1
9392       GOTO 9999
9393  9998 IRCRON(3) = IRCRON(3)+1
9394
9395  9999 CONTINUE
9396       DO 100 K=1,4
9397          POUT(K) = PIN(K)
9398   100 CONTINUE
9399       RETURN
9400       END
9401
9402 *$ CREATE DT_COM2CR.FOR
9403 *COPY DT_COM2CR
9404 *
9405 *===com2sr=============================================================*
9406 *
9407       SUBROUTINE DT_COM2CR
9408
9409 ************************************************************************
9410 * COMbine q-aq chains to Color Ropes (qq-aqaq).                        *
9411 *        CUTOF      parameter determining minimum number of not        *
9412 *                   combined q-aq chains                               *
9413 * This subroutine replaces KKEVCC etc.                                 *
9414 * This version dated 11.01.95 is written by S. Roesler.                *
9415 ************************************************************************
9416
9417       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9418       SAVE
9419
9420       PARAMETER ( LINP = 10 ,
9421      &            LOUT = 6 ,
9422      &            LDAT = 9 )
9423
9424 * event history
9425
9426       PARAMETER (NMXHKK=200000)
9427
9428       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9429      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9430      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9431
9432 * extended event history
9433       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9434      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9435      &                IHIST(2,NMXHKK)
9436
9437 * statistics
9438       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9439      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9440      &                ICEVTG(8,0:30)
9441
9442 * various options for treatment of partons (DTUNUC 1.x)
9443 * (chain recombination, Cronin,..)
9444       LOGICAL LCO2CR,LINTPT
9445       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9446      &                LCO2CR,LINTPT
9447
9448       DIMENSION IDXQA(248),IDXAQ(248)
9449
9450       ICCHAI(1,9) = ICCHAI(1,9)+1
9451       NQA = 0
9452       NAQ = 0
9453 * scan DTEVT1 for q-aq, aq-q chains
9454       DO 10 I=NPOINT(3),NHKK
9455 * skip "chains" which are resonances
9456          IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
9457             MO1 = JMOHKK(1,I)
9458             MO2 = JMOHKK(2,I)
9459             IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
9460 * q-aq, aq-q chain found, keep index
9461                IF (IDHKK(MO1).GT.0) THEN
9462                   NQA = NQA+1
9463                   IDXQA(NQA) = I
9464                ELSE
9465                   NAQ = NAQ+1
9466                   IDXAQ(NAQ) = I
9467                ENDIF
9468             ENDIF
9469          ENDIF
9470    10 CONTINUE
9471
9472 * minimum number of q-aq chains requested for the same projectile/
9473 * target
9474       NCHMIN = IDT_NPOISS(CUTOF)
9475
9476 * combine q-aq chains of the same projectile
9477       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
9478 * combine q-aq chains of the same target
9479       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9480 * combine aq-q chains of the same projectile
9481       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9482 * combine aq-q chains of the same target
9483       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9484
9485       RETURN
9486       END
9487
9488 *$ CREATE DT_SCN4CR.FOR
9489 *COPY DT_SCN4CR
9490 *
9491 *===scn4cr=============================================================*
9492 *
9493       SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9494
9495 ************************************************************************
9496 * SCan q-aq chains for Color Ropes.                                    *
9497 * This version dated 11.01.95 is written by S. Roesler.                *
9498 ************************************************************************
9499
9500       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9501       SAVE
9502
9503       PARAMETER ( LINP = 10 ,
9504      &            LOUT = 6 ,
9505      &            LDAT = 9 )
9506
9507 * event history
9508
9509       PARAMETER (NMXHKK=200000)
9510
9511       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9512      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9513      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9514
9515 * extended event history
9516       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9517      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9518      &                IHIST(2,NMXHKK)
9519
9520       DIMENSION IDXCH(248),IDXJN(248)
9521
9522       DO 1 I=1,NCH
9523          IF (IDXCH(I).GT.0) THEN
9524             NJOIN = 1
9525             IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9526             IDXJN(NJOIN) = I
9527             IF (I.LT.NCH) THEN
9528                DO 2 J=I+1,NCH
9529                   IF (IDXCH(J).GT.0) THEN
9530                      IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9531                      IF (IDXMO.EQ.IDXMO1) THEN
9532                         NJOIN = NJOIN+1
9533                         IDXJN(NJOIN) = J
9534                      ENDIF
9535                   ENDIF
9536     2          CONTINUE
9537             ENDIF
9538             IF (NJOIN.GE.NCHMIN+2) THEN
9539                NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9540                DO 3 J=1,2*NJ,2
9541                   CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9542                   IF (IREJ1.NE.0) GOTO 3
9543                   IDXCH(IDXJN(J))   = 0
9544                   IDXCH(IDXJN(J+1)) = 0
9545     3          CONTINUE
9546             ENDIF
9547          ENDIF
9548     1 CONTINUE
9549
9550       RETURN
9551       END
9552
9553 *$ CREATE DT_JOIN.FOR
9554 *COPY DT_JOIN
9555 *
9556 *===join===============================================================*
9557 *
9558       SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9559
9560 ************************************************************************
9561 * This subroutine joins two q-aq chains to one qq-aqaq chain.          *
9562 *     IDX1, IDX2       DTEVT1 indices of chains to be joined           *
9563 * This version dated 11.01.95 is written by S. Roesler.                *
9564 ************************************************************************
9565
9566       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9567       SAVE
9568
9569       PARAMETER ( LINP = 10 ,
9570      &            LOUT = 6 ,
9571      &            LDAT = 9 )
9572
9573 * event history
9574
9575       PARAMETER (NMXHKK=200000)
9576
9577       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9578      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9579      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9580
9581 * extended event history
9582       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9583      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9584      &                IHIST(2,NMXHKK)
9585
9586 * flags for input different options
9587       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9588       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9589      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9590
9591 * statistics
9592       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9593      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9594      &                ICEVTG(8,0:30)
9595
9596       DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9597
9598       IREJ   = 0
9599
9600       IDX(1) = IDX1
9601       IDX(2) = IDX2
9602       DO 1 I=1,2
9603          DO 2 J=1,2
9604             MO(I,J) = JMOHKK(J,IDX(I))
9605             ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9606     2    CONTINUE
9607     1 CONTINUE
9608
9609 * check consistency
9610       IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9611      &    (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9612      &    ((ID(1,1)*ID(2,1)).LT.0).OR.
9613      &    ((ID(1,2)*ID(2,2)).LT.0)) THEN
9614          WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9615      &                    MO(2,2)
9616  1000    FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9617      &             2I5,' chain ',I4,':',2I5)
9618       ENDIF
9619
9620 * join chains
9621       DO 3 K=1,4
9622          PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9623          PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9624     3 CONTINUE
9625       IF1  = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9626       IF2  = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9627       IST1 = ISTHKK(MO(1,1))
9628       IST2 = ISTHKK(MO(1,2))
9629
9630 * put partons again on mass shell
9631       XM1 = 0.0D0
9632       XM2 = 0.0D0
9633       IF (IMSHL.EQ.1) THEN
9634
9635          XM1 = PYMASS(IF1)
9636          XM2 = PYMASS(IF2)
9637
9638       ENDIF
9639       CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9640       IF (IREJ1.NE.0) GOTO 9999
9641       DO 4 I=1,4
9642          PP(I) = P1(I)
9643          PT(I) = P2(I)
9644     4 CONTINUE
9645
9646 * store new partons in DTEVT1
9647       CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9648      &                                                       0,0,0)
9649       CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9650      &                                                       0,0,0)
9651       DO 5 K=1,4
9652          PCH(K) = PP(K)+PT(K)
9653     5 CONTINUE
9654
9655 * check new chain for lower mass limit
9656       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9657          AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9658          CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9659      &               AMCH,AMCHN,3,IREJ1)
9660          IF (IREJ1.NE.0) THEN
9661             NHKK = NHKK-2
9662             GOTO 9999
9663          ENDIF
9664       ENDIF
9665
9666       ICCHAI(2,9) = ICCHAI(2,9)+1
9667 * store new chain in DTEVT1
9668       KCH = 191
9669       CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9670       IDHKK(IDX(1)) = 22222
9671       IDHKK(IDX(2)) = 22222
9672 * special treatment for space-time coordinates
9673       DO 6 K=1,4
9674          VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9675          WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9676     6 CONTINUE
9677       RETURN
9678
9679  9999 CONTINUE
9680       IREJ = 1
9681       RETURN
9682       END
9683 *$ CREATE DT_XSGLAU.FOR
9684 *COPY DT_XSGLAU
9685 *
9686 *===xsglau=============================================================*
9687 *
9688       SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9689
9690 ************************************************************************
9691 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9692 * Glauber's approach.                                                  *
9693 *  NA / NB     mass numbers of proj./target nuclei                     *
9694 *  JJPROJ      bamjet-index of projectile (=1 in case of proj.nucleus) *
9695 *  XI,Q2I,ECMI kinematical variables x, Q^2, E_cm                      *
9696 *  IE,IQ       indices of energy and virtuality (the latter for gamma  *
9697 *              projectiles only)                                       *
9698 *  NIDX        index of projectile/target nucleus                      *
9699 * This version dated 17.3.98  is written by S. Roesler                 *
9700 ************************************************************************
9701
9702       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9703       SAVE
9704
9705       PARAMETER ( LINP = 10 ,
9706      &            LOUT = 6 ,
9707      &            LDAT = 9 )
9708
9709       COMPLEX*16 CZERO,CONE,CTWO
9710       CHARACTER*12 CFILE
9711       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9712      &           ONETHI=ONE/THREE,TINY25=1.0D-25)
9713       PARAMETER (TWOPI  = 6.283185307179586454D+00,
9714      &           PI     = TWOPI/TWO,
9715      &           GEV2MB = 0.38938D0,
9716      &           GEV2FM = 0.1972D0,
9717      &           ALPHEM = ONE/137.0D0,
9718 * proton mass
9719      &           AMP    = 0.938D0,
9720      &           AMP2   = AMP**2,
9721 * approx. nucleon radius
9722      &           RNUCLE = 1.12D0)
9723
9724 * particle properties (BAMJET index convention)
9725       CHARACTER*8  ANAME
9726       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9727      &                IICH(210),IIBAR(210),K1(210),K2(210)
9728
9729       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9730
9731       PARAMETER ( MAXNCL = 260,
9732
9733      &            MAXVQU = MAXNCL,
9734      &            MAXSQU = 20*MAXVQU,
9735      &            MAXINT = MAXVQU+MAXSQU)
9736
9737 * Glauber formalism: parameters
9738       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9739      &                BMAX(NCOMPX),BSTEP(NCOMPX),
9740      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9741      &                NSITEB,NSTATB
9742
9743 * Glauber formalism: cross sections
9744       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9745      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9746      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9747      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9748      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9749      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9750      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9751      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9752      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9753      &                BSLOPE,NEBINI,NQBINI
9754
9755 * Glauber formalism: flags and parameters for statistics
9756       LOGICAL LPROD
9757       CHARACTER*8 CGLB
9758       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9759
9760 * nucleon-nucleon event-generator
9761       CHARACTER*8 CMODEL
9762       LOGICAL LPHOIN
9763       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9764
9765 * VDM parameter for photon-nucleus interactions
9766       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9767
9768 * parameters for hA-diffraction
9769       COMMON /DTDIHA/ DIBETA,DIALPH
9770
9771       COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9772      &           OMPP11,OMPP12,OMPP21,OMPP22,
9773      &           DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9774      &           PPTMP1,PPTMP2
9775       COMPLEX*16 C,CA,CI
9776       DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9777      &          COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9778      &          BPROD(KSITEB)
9779
9780       PARAMETER (NPOINT=16)
9781       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9782
9783       LOGICAL LFIRST,LOPEN
9784       DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9785
9786       NTARG = ABS(NIDX)
9787 * for quasi-elastic neutrino scattering set projectile to proton
9788 * it should not have an effect since the whole Glauber-formalism is
9789 * not needed for these interactions..
9790       IF (MCGENE.EQ.4) THEN
9791          IJPROJ = 1
9792       ELSE
9793          IJPROJ = JJPROJ
9794       ENDIF
9795
9796       IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9797          I = INDEX(CGLB,' ')
9798          IF (I.EQ.0) THEN
9799             CFILE = CGLB//'.glb'
9800             OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9801          ELSEIF (I.GT.1) THEN
9802             CFILE = CGLB(1:I-1)//'.glb'
9803             OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9804          ELSE
9805             STOP 'XSGLAU 1'
9806          ENDIF
9807          LOPEN = .TRUE.
9808       ENDIF
9809
9810       CZERO  = DCMPLX(ZERO,ZERO)
9811       CONE   = DCMPLX(ONE,ZERO)
9812       CTWO   = DCMPLX(TWO,ZERO)
9813       NEBINI = IE
9814       NQBINI = IQ
9815
9816 * re-define kinematics
9817       S  = ECMI**2
9818       Q2 = Q2I
9819       X  = XI
9820 *  g(Q2=0)-A, h-A, A-A scattering
9821       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9822          Q2 = 0.0001D0
9823          X  = Q2/(S+Q2-AMP2)
9824 *  g(Q2>0)-A scattering
9825       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9826          X  = Q2/(S+Q2-AMP2)
9827       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9828          Q2 = (S-AMP2)*X/(ONE-X)
9829       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9830          S  = Q2*(ONE-X)/X+AMP2
9831       ELSE
9832          WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9833          STOP
9834       ENDIF
9835       ECMNN(IE) = SQRT(S)
9836       Q2G(IQ)   = Q2
9837       XNU = (S+Q2-AMP2)/(TWO*AMP)
9838
9839 * parameters determining statistics in evaluating Glauber-xsection
9840       NSTATB = JSTATB
9841       NSITEB = JBINSB
9842       IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9843
9844 * set up interaction geometry (common /DTGLAM/)
9845 *  projectile/target radii
9846       RPRNCL = DT_RNCLUS(NA)
9847       RTANCL = DT_RNCLUS(NB)
9848       IF (IJPROJ.EQ.7) THEN
9849          RASH(1) = ZERO
9850          RBSH(NTARG) = RTANCL
9851          BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9852       ELSE
9853          IF (NIDX.LE.-1) THEN
9854             RASH(1)     = RPRNCL
9855             RBSH(NTARG) = RTANCL
9856             BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9857          ELSE
9858             RASH(NTARG) = RPRNCL
9859             RBSH(1)     = RTANCL
9860             BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9861          ENDIF
9862       ENDIF
9863 *  maximum impact-parameter
9864       BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9865
9866 * slope, rho ( Re(f(0))/Im(f(0)) )
9867       IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9868          IF (MCGENE.EQ.2) THEN
9869             ZERO1 = ZERO
9870             CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9871      &                                                   BSLOPE,0)
9872          ELSE
9873             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9874          ENDIF
9875          IF (ECMNN(IE).LE.3.0D0) THEN
9876             ROSH = -0.43D0
9877          ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9878             ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9879          ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9880             ROSH = 0.1D0
9881          ENDIF
9882       ELSEIF (IJPROJ.EQ.7) THEN
9883          ROSH = 0.1D0
9884       ELSE
9885          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9886          ROSH   = 0.01D0
9887       ENDIF
9888
9889 * projectile-nucleon xsection (in fm)
9890       IF (IJPROJ.EQ.7) THEN
9891          SIGSH = DT_SIGVP(X,Q2)/10.0D0
9892       ELSE
9893          ELAB  = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9894          PLAB  = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9895 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9896          DUMZER = ZERO
9897          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9898          SIGSH = SIGSH/10.0D0
9899       ENDIF
9900
9901 * parameters for projectile diffraction (hA scattering only)
9902       IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9903      &                               .AND.(DIBETA.GE.ZERO)) THEN
9904          ZERO1 = ZERO
9905          CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9906 C        DIBETA = SDIF1/STOT
9907          DIBETA = 0.2D0
9908          DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9909          IF (DIBETA.LE.ZERO) THEN
9910             ALPGAM = ONE
9911          ELSE
9912             ALPGAM = DIALPH/DIGAMM
9913          ENDIF
9914          FACDI1 = ONE-ALPGAM
9915          FACDI2 = ONE+ALPGAM
9916          FACDI  = SQRT(FACDI1*FACDI2)
9917          WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9918       ELSE
9919          DIBETA = -1.0D0
9920          DIALPH = ZERO
9921          DIGAMM = ZERO
9922          FACDI1 = ZERO
9923          FACDI2 = 2.0D0
9924          FACDI  = ZERO
9925       ENDIF
9926
9927 * initializations
9928       DO 10 I=1,NSITEB
9929          BSITE( 0,IQ,NTARG,I) = ZERO
9930          BSITE(IE,IQ,NTARG,I) = ZERO
9931          BPROD(I) = ZERO
9932    10 CONTINUE
9933       STOT  = ZERO
9934       STOT2 = ZERO
9935       SELA  = ZERO
9936       SELA2 = ZERO
9937       SQEP  = ZERO
9938       SQEP2 = ZERO
9939       SQET  = ZERO
9940       SQET2 = ZERO
9941       SQE2  = ZERO
9942       SQE22 = ZERO
9943       SPRO  = ZERO
9944       SPRO2 = ZERO
9945       SDEL  = ZERO
9946       SDEL2 = ZERO
9947       SDQE  = ZERO
9948       SDQE2 = ZERO
9949       FACN   = ONE/DBLE(NSTATB)
9950
9951       IPNT = 0
9952       RPNT = ZERO
9953
9954 *  initialize Gauss-integration for photon-proj.
9955       JPOINT = 1
9956       IF (IJPROJ.EQ.7) THEN
9957          IF (INTRGE(1).EQ.1) THEN
9958             AMLO2 = (3.0D0*AAM(13))**2
9959          ELSEIF (INTRGE(1).EQ.2) THEN
9960             AMLO2 = AAM(33)**2
9961          ELSE
9962             AMLO2 = AAM(96)**2
9963          ENDIF
9964          IF (INTRGE(2).EQ.1) THEN
9965             AMHI2 = S/TWO
9966          ELSEIF (INTRGE(2).EQ.2) THEN
9967             AMHI2 = S/4.0D0
9968          ELSE
9969             AMHI2 = S
9970          ENDIF
9971          AMHI20 = (ECMNN(IE)-AMP)**2
9972          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9973          XAMLO = LOG( AMLO2+Q2 )
9974          XAMHI = LOG( AMHI2+Q2 )
9975 **PHOJET105a
9976 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9977 **PHOJET112
9978
9979          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9980
9981 **
9982          JPOINT = NPOINT
9983 * ratio direct/total photon-nucleon xsection
9984          CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9985       ENDIF
9986
9987 * read pre-initialized profile-function from file
9988       IF (IOGLB.EQ.1) THEN
9989          READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
9990          IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
9991             WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
9992      &                             NA,NB,NSTATB,NSITEB
9993  1000       FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
9994      &             ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
9995      &             ' (NA,NB,NSTATB,NSITEB) ',4I10)
9996             STOP
9997          ENDIF
9998          IF (LFIRST) WRITE(LOUT,1001) CFILE
9999  1001    FORMAT(/,' XSGLAU: impact parameter distribution read from ',
10000      &          'file ',A12,/)
10001          READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
10002      &                         XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
10003      &                         XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10004          READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
10005      &                         XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
10006      &                         XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10007          NLINES = INT(DBLE(NSITEB)/7.0D0)
10008          IF (NLINES.GT.0) THEN
10009             DO 21 I=1,NLINES
10010                ISTART = 7*I-6
10011                READ(LDAT,'(7E11.4)')
10012      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10013    21       CONTINUE
10014          ENDIF
10015          ISTART = 7*NLINES+1
10016          IF (ISTART.LE.NSITEB) THEN
10017             READ(LDAT,'(7E11.4)')
10018      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10019          ENDIF
10020          LFIRST = .FALSE.
10021          GOTO 100
10022 * variable projectile/target/energy runs:
10023 * read pre-initialized profile-functions from file
10024       ELSEIF (IOGLB.EQ.100) THEN
10025          CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
10026          GOTO 100
10027       ENDIF
10028
10029 * cross sections averaged over NSTATB nucleon configurations
10030       DO 11 IS=1,NSTATB
10031 C        IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
10032          STOTN = ZERO
10033          SELAN = ZERO
10034          SQEPN = ZERO
10035          SQETN = ZERO
10036          SQE2N = ZERO
10037          SPRON = ZERO
10038          SDELN = ZERO
10039          SDQEN = ZERO
10040
10041          IF (NIDX.LE.-1) THEN
10042             CALL DT_CONUCL(COOP1,NA,RASH(1),0)
10043             CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
10044             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10045                CALL DT_CONUCL(COOP2,NA,RASH(1),0)
10046                CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
10047             ENDIF
10048          ELSE
10049             CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
10050             CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
10051             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10052                CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
10053                CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
10054             ENDIF
10055          ENDIF
10056
10057 *  integration over impact parameter B
10058          DO 12 IB=1,NSITEB-1
10059             STOTB = ZERO
10060             SELAB = ZERO
10061             SQEPB = ZERO
10062             SQETB = ZERO
10063             SQE2B = ZERO
10064             SPROB = ZERO
10065             SDIR  = ZERO
10066             SDELB = ZERO
10067             SDQEB = ZERO
10068             B     = DBLE(IB)*BSTEP(NTARG)
10069             FACB  = 10.0D0*TWOPI*B*BSTEP(NTARG)
10070
10071 *   integration over M_V^2 for photon-proj.
10072             DO 14 IM=1,JPOINT
10073                PP11(1) = CONE
10074                PP12(1) = CONE
10075                PP21(1) = CONE
10076                PP22(1) = CONE
10077                IF (IJPROJ.EQ.7) THEN
10078                   DO 13 K=2,NB
10079                      PP11(K) = CONE
10080                      PP12(K) = CONE
10081                      PP21(K) = CONE
10082                      PP22(K) = CONE
10083    13             CONTINUE
10084                ENDIF
10085                SHI  = ZERO
10086                FACM = ONE
10087                DCOH = 1.0D10
10088
10089                IF (IJPROJ.EQ.7) THEN
10090                   AMV2 = EXP(ABSZX(IM))-Q2
10091                   AMV  = SQRT(AMV2)
10092                   IF (AMV2.LT.16.0D0) THEN
10093                      R = TWO
10094                   ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
10095                      R = 10.0D0/3.0D0
10096                   ELSE
10097                      R = 11.0D0/3.0D0
10098                   ENDIF
10099 *    define M_V dependent properties of nucleon scattering amplitude
10100 *     V_M-nucleon xsection
10101                   SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
10102                   SIGMV  = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
10103 *     slope-parametrisation a la Kaidalov
10104                   BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
10105      &                           +0.25D0*LOG(S/(AMV2+Q2)))
10106 *    coherence length
10107                   IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
10108 *    integration weight factor
10109                   FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
10110      &                  R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
10111                ENDIF
10112                GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10113                GAM = GSH
10114                IF (IJPROJ.EQ.7) THEN
10115                   RCA = GAM*SIGMV/TWOPI
10116                ELSE
10117                   RCA = GAM*SIGSH/TWOPI
10118                ENDIF
10119                FCA = -ROSH*RCA
10120                CA  = DCMPLX(RCA,FCA)
10121                CI  = CONE
10122
10123                DO 15 INA=1,NA
10124                   KK1  = 1
10125                   INT1 = 1
10126                   KK2  = 1
10127                   INT2 = 1
10128                   DO 16 INB=1,NB
10129 *    photon-projectile: check for supression by coherence length
10130                      IF (IJPROJ.EQ.7) THEN
10131                         IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
10132                            KK1  = INB
10133                            INT1 = INT1+1
10134                         ENDIF
10135                         IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
10136                            KK2  = INB
10137                            INT2 = INT2+1
10138                         ENDIF
10139                      ENDIF
10140
10141                      X11 = B+COOT1(1,INB)-COOP1(1,INA)
10142                      Y11 =   COOT1(2,INB)-COOP1(2,INA)
10143                      XY11 = GAM*(X11*X11+Y11*Y11)
10144                      IF (XY11.LE.15.0D0) THEN
10145                         C = CONE-CA*EXP(-XY11)
10146                         AR = DBLE(PP11(INT1))
10147                         AI = DIMAG(PP11(INT1))
10148                         IF (ABS(AR).LT.TINY25) AR = ZERO
10149                         IF (ABS(AI).LT.TINY25) AI = ZERO
10150                         PP11(INT1) = DCMPLX(AR,AI)
10151                         PP11(INT1) = PP11(INT1)*C
10152                         AR  = DBLE(C)
10153                         AI  = DIMAG(C)
10154                         SHI = SHI+LOG(AR*AR+AI*AI)
10155                      ENDIF
10156                      IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10157                         X12 = B+COOT2(1,INB)-COOP1(1,INA)
10158                         Y12 =   COOT2(2,INB)-COOP1(2,INA)
10159                         XY12 = GAM*(X12*X12+Y12*Y12)
10160                         IF (XY12.LE.15.0D0) THEN
10161                            C = CONE-CA*EXP(-XY12)
10162                            AR = DBLE(PP12(INT2))
10163                            AI = DIMAG(PP12(INT2))
10164                            IF (ABS(AR).LT.TINY25) AR = ZERO
10165                            IF (ABS(AI).LT.TINY25) AI = ZERO
10166                            PP12(INT2) = DCMPLX(AR,AI)
10167                            PP12(INT2) = PP12(INT2)*C
10168                         ENDIF
10169                         X21 = B+COOT1(1,INB)-COOP2(1,INA)
10170                         Y21 =   COOT1(2,INB)-COOP2(2,INA)
10171                         XY21 = GAM*(X21*X21+Y21*Y21)
10172                         IF (XY21.LE.15.0D0) THEN
10173                            C = CONE-CA*EXP(-XY21)
10174                            AR = DBLE(PP21(INT1))
10175                            AI = DIMAG(PP21(INT1))
10176                            IF (ABS(AR).LT.TINY25) AR = ZERO
10177                            IF (ABS(AI).LT.TINY25) AI = ZERO
10178                            PP21(INT1) = DCMPLX(AR,AI)
10179                            PP21(INT1) = PP21(INT1)*C
10180                         ENDIF
10181                         X22 = B+COOT2(1,INB)-COOP2(1,INA)
10182                         Y22 =   COOT2(2,INB)-COOP2(2,INA)
10183                         XY22 = GAM*(X22*X22+Y22*Y22)
10184                         IF (XY22.LE.15.0D0) THEN
10185                            C = CONE-CA*EXP(-XY22)
10186                            AR = DBLE(PP22(INT2))
10187                            AI = DIMAG(PP22(INT2))
10188                            IF (ABS(AR).LT.TINY25) AR = ZERO
10189                            IF (ABS(AI).LT.TINY25) AI = ZERO
10190                            PP22(INT2) = DCMPLX(AR,AI)
10191                            PP22(INT2) = PP22(INT2)*C
10192                         ENDIF
10193                      ENDIF
10194    16             CONTINUE
10195    15          CONTINUE
10196
10197                OMPP11 = CZERO
10198                OMPP21 = CZERO
10199                DIPP11 = CZERO
10200                DIPP21 = CZERO
10201                DO 17 K=1,INT1
10202                   IF (PP11(K).EQ.CZERO) THEN
10203                      PPTMP1 = CZERO
10204                      PPTMP2 = CZERO
10205                   ELSE
10206                      PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
10207                      PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
10208                   ENDIF
10209                   AVDIPP = 0.5D0*
10210      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10211                   OMPP11 = OMPP11+AVDIPP
10212 C                 OMPP11 = OMPP11+(CONE-PP11(K))
10213                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10214                   DIPP11 = DIPP11+AVDIPP
10215                   IF (PP21(K).EQ.CZERO) THEN
10216                      PPTMP1 = CZERO
10217                      PPTMP2 = CZERO
10218                   ELSE
10219                      PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
10220                      PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
10221                   ENDIF
10222                   AVDIPP = 0.5D0*
10223      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10224                   OMPP21 = OMPP21+AVDIPP
10225 C                 OMPP21 = OMPP21+(CONE-PP21(K))
10226                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10227                   DIPP21 = DIPP21+AVDIPP
10228    17          CONTINUE
10229                OMPP12 = CZERO
10230                OMPP22 = CZERO
10231                DIPP12 = CZERO
10232                DIPP22 = CZERO
10233                DO 18 K=1,INT2
10234                   IF (PP12(K).EQ.CZERO) THEN
10235                      PPTMP1 = CZERO
10236                      PPTMP2 = CZERO
10237                   ELSE
10238                      PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
10239                      PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
10240                   ENDIF
10241                   AVDIPP = 0.5D0*
10242      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10243                   OMPP12 = OMPP12+AVDIPP
10244 C                 OMPP12 = OMPP12+(CONE-PP12(K))
10245                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10246                   DIPP12 = DIPP12+AVDIPP
10247                   IF (PP22(K).EQ.CZERO) THEN
10248                      PPTMP1 = CZERO
10249                      PPTMP2 = CZERO
10250                   ELSE
10251                      PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
10252                      PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
10253                   ENDIF
10254                   AVDIPP = 0.5D0*
10255      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10256                   OMPP22 = OMPP22+AVDIPP
10257 C                 OMPP22 = OMPP22+(CONE-PP22(K))
10258                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10259                   DIPP22 = DIPP22+AVDIPP
10260    18          CONTINUE
10261
10262                SPROM = ONE-EXP(SHI)
10263                SPROB = SPROB+FACM*SPROM
10264                IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10265                   STOTM = DBLE(OMPP11+OMPP22)
10266                   SELAM = DBLE(OMPP11*DCONJG(OMPP22))
10267                   SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
10268                   SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
10269                   SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
10270                   SDELM = DBLE(DIPP11*DCONJG(DIPP22))
10271                   SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
10272                   STOTB = STOTB+FACM*STOTM
10273                   SELAB = SELAB+FACM*SELAM
10274                   SDELB = SDELB+FACM*SDELM
10275                   IF (NB.GT.1) THEN
10276                      SQEPB = SQEPB+FACM*SQEPM
10277                      SDQEB = SDQEB+FACM*SDQEM
10278                   ENDIF
10279                   IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
10280                   IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
10281                   IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
10282                ENDIF
10283
10284    14       CONTINUE
10285
10286             STOTN = STOTN+FACB*STOTB
10287             SELAN = SELAN+FACB*SELAB
10288             SQEPN = SQEPN+FACB*SQEPB
10289             SQETN = SQETN+FACB*SQETB
10290             SQE2N = SQE2N+FACB*SQE2B
10291             SPRON = SPRON+FACB*SPROB
10292             SDELN = SDELN+FACB*SDELB
10293             SDQEN = SDQEN+FACB*SDQEB
10294
10295             IF (IJPROJ.EQ.7) THEN
10296                BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
10297             ELSE
10298                IF (DIBETA.GT.ZERO) THEN
10299                   BPROD(IB+1)= BPROD(IB+1)
10300      &                        +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
10301                ELSE
10302                   BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
10303                ENDIF
10304             ENDIF
10305
10306    12    CONTINUE
10307
10308          STOT  = STOT +FACN*STOTN
10309          STOT2 = STOT2+FACN*STOTN**2
10310          SELA  = SELA +FACN*SELAN
10311          SELA2 = SELA2+FACN*SELAN**2
10312          SQEP  = SQEP +FACN*SQEPN
10313          SQEP2 = SQEP2+FACN*SQEPN**2
10314          SQET  = SQET +FACN*SQETN
10315          SQET2 = SQET2+FACN*SQETN**2
10316          SQE2  = SQE2 +FACN*SQE2N
10317          SQE22 = SQE22+FACN*SQE2N**2
10318          SPRO  = SPRO +FACN*SPRON
10319          SPRO2 = SPRO2+FACN*SPRON**2
10320          SDEL  = SDEL +FACN*SDELN
10321          SDEL2 = SDEL2+FACN*SDELN**2
10322          SDQE  = SDQE +FACN*SDQEN
10323          SDQE2 = SDQE2+FACN*SDQEN**2
10324
10325    11 CONTINUE
10326
10327 * final cross sections
10328 * 1) total
10329       XSTOT(IE,IQ,NTARG) = STOT
10330       IF (IJPROJ.EQ.7)
10331      &   XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
10332 * 2) elastic
10333       XSELA(IE,IQ,NTARG) = SELA
10334 * 3) quasi-el.: A+B-->A+X (excluding 2)
10335       XSQEP(IE,IQ,NTARG) = SQEP
10336 * 4) quasi-el.: A+B-->X+B (excluding 2)
10337       XSQET(IE,IQ,NTARG) = SQET
10338 * 5) quasi-el.: A+B-->X (excluding 2-4)
10339       XSQE2(IE,IQ,NTARG) = SQE2
10340 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
10341       IF (SDEL.GT.ZERO) THEN
10342          XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
10343       ELSE
10344          XSPRO(IE,IQ,NTARG) = SPRO
10345       ENDIF
10346 * 7) projectile diffraction (el. scatt. off target)
10347       XSDEL(IE,IQ,NTARG) = SDEL
10348 * 8) projectile diffraction (quasi-el. scatt. off target)
10349       XSDQE(IE,IQ,NTARG) = SDQE
10350 *  stat. errors
10351       XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
10352       XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
10353       XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
10354       XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
10355       XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
10356       XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
10357       XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
10358       XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
10359
10360       IF (IJPROJ.EQ.7) THEN
10361          BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
10362      &          -XSQEP(IE,IQ,NTARG)
10363       ELSE
10364          BNORM = XSPRO(IE,IQ,NTARG)
10365       ENDIF
10366       DO 19 I=2,NSITEB
10367          BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
10368          IF ((IE.EQ.1).AND.(IQ.EQ.1))
10369      &      BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
10370    19 CONTINUE
10371
10372 * write profile function data into file
10373       IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
10374          WRITE(LDAT,'(5I10,1P,E15.5)')
10375      &      IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
10376          WRITE(LDAT,'(1P,6E12.5)')
10377      &      XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
10378      &      XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10379          WRITE(LDAT,'(1P,6E12.5)')
10380      &      XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
10381      &      XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10382          NLINES = INT(DBLE(NSITEB)/7.0D0)
10383          IF (NLINES.GT.0) THEN
10384             DO 20 I=1,NLINES
10385                ISTART = 7*I-6
10386                WRITE(LDAT,'(1P,7E11.4)')
10387      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10388    20       CONTINUE
10389          ENDIF
10390          ISTART = 7*NLINES+1
10391          IF (ISTART.LE.NSITEB) THEN
10392             WRITE(LDAT,'(1P,7E11.4)')
10393      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10394          ENDIF
10395       ENDIF
10396
10397   100 CONTINUE
10398
10399 C     IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
10400
10401       RETURN
10402       END
10403
10404 *$ CREATE DT_GETBXS.FOR
10405 *COPY DT_GETBXS
10406 *
10407 *===getbxs=============================================================*
10408 *
10409       SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
10410
10411 ************************************************************************
10412 * Biasing in impact parameter space.                                   *
10413 *     XSFRAC = 0 :  BLO    - minimum impact parameter  (input)         *
10414 *                   BHI    - maximum impact parameter  (input)         *
10415 *                   XSFRAC - fraction of cross section corresponding   *
10416 *                            to impact parameter range (BLO,BHI)       *
10417 *                                                      (output)        *
10418 *     XSFRAC > 0 :  XSFRAC - fraction of cross section (input)         *
10419 *                   BHI    - maximum impact parameter giving requested *
10420 *                            fraction of cross section in impact       *
10421 *                            parameter range (0,BMAX)  (output)        *
10422 * This version dated 17.03.00  is written by S. Roesler                *
10423 ************************************************************************
10424
10425       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10426       SAVE
10427
10428       PARAMETER ( LINP = 10 ,
10429      &            LOUT = 6 ,
10430      &            LDAT = 9 )
10431
10432       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10433
10434 * Glauber formalism: parameters
10435       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10436      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10437      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10438      &                NSITEB,NSTATB
10439
10440       NTARG = ABS(NIDX)
10441       IF (XSFRAC.LE.0.0D0) THEN
10442          ILO    = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
10443          IHI    = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
10444          IF (ILO.GE.IHI) THEN
10445             XSFRAC = 0.0D0
10446             RETURN
10447          ENDIF
10448          IF (ILO.EQ.NSITEB-1) THEN
10449             FRCLO = BSITE(0,1,NTARG,NSITEB)
10450          ELSE
10451             FRCLO = BSITE(0,1,NTARG,ILO+1)
10452      &              +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
10453      &              *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
10454          ENDIF
10455          IF (IHI.EQ.NSITEB-1) THEN
10456             FRCHI = BSITE(0,1,NTARG,NSITEB)
10457          ELSE
10458             FRCHI = BSITE(0,1,NTARG,IHI+1)
10459      &              +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
10460      &              *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
10461          ENDIF
10462          XSFRAC = FRCHI-FRCLO
10463       ELSE
10464          BLO = 0.0D0
10465          BHI = BMAX(NTARG)
10466          DO 1 I=1,NSITEB-1
10467             IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
10468                FAC = (XSFRAC              -BSITE(0,1,NTARG,I))/
10469      &               (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
10470                BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
10471                GOTO 2
10472             ENDIF
10473     1    CONTINUE
10474     2    CONTINUE
10475       ENDIF
10476
10477       RETURN
10478       END
10479
10480 *$ CREATE DT_CONUCL.FOR
10481 *COPY DT_CONUCL
10482 *
10483 *===conucl=============================================================*
10484 *
10485       SUBROUTINE DT_CONUCL(X,N,R,MODE)
10486
10487 ************************************************************************
10488 * Calculation of coordinates of nucleons within nuclei.                *
10489 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10490 *        N / R    number of nucleons / radius of nucleus   (input)     *
10491 *        MODE = 0 coordinates not sorted                               *
10492 *             = 1 coordinates sorted with increasing X(3,i)            *
10493 *             = 2 coordinates sorted with decreasing X(3,i)            *
10494 * This version dated 26.10.95 is revised by S. Roesler                 *
10495 ************************************************************************
10496
10497       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10498       SAVE
10499
10500       PARAMETER ( LINP = 10 ,
10501      &            LOUT = 6 ,
10502      &            LDAT = 9 )
10503
10504       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10505      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10506
10507       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10508
10509       PARAMETER (NSRT=10)
10510       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10511       DIMENSION X(3,N),XTMP(3,260)
10512
10513       CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10514
10515       IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10516          K = 0
10517          DO 1 I=1,NSRT
10518             IF (MODE.EQ.2) THEN
10519                ISRT = NSRT+1-I
10520             ELSE
10521                ISRT = I
10522             ENDIF
10523             K1 = K
10524             DO 2 J=1,ICSRT(ISRT)
10525                K = K+1
10526                X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10527                X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10528                X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10529     2       CONTINUE
10530             IF (ICSRT(ISRT).GT.1) THEN
10531                I0 = K1+1
10532                I1 = K
10533                CALL DT_SORT(X,N,I0,I1,MODE)
10534             ENDIF
10535     1    CONTINUE
10536       ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10537          DO 3 I=1,N
10538             X(1,I) = XTMP(1,I)
10539             X(2,I) = XTMP(2,I)
10540             X(3,I) = XTMP(3,I)
10541     3    CONTINUE
10542          CALL DT_SORT(X,N,1,N,MODE)
10543       ELSE
10544          DO 4 I=1,N
10545             X(1,I) = XTMP(1,I)
10546             X(2,I) = XTMP(2,I)
10547             X(3,I) = XTMP(3,I)
10548     4    CONTINUE
10549       ENDIF
10550
10551       RETURN
10552       END
10553
10554 *$ CREATE DT_COORDI.FOR
10555 *COPY DT_COORDI
10556 *
10557 *===coordi=============================================================*
10558 *
10559       SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10560
10561 ************************************************************************
10562 * Calculation of coordinates of nucleons within nuclei.                *
10563 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10564 *        N / R    number of nucleons / radius of nucleus   (input)     *
10565 * Based on the original version by Shmakov et al.                      *
10566 * This version dated 26.10.95 is revised by S. Roesler                 *
10567 ************************************************************************
10568
10569       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10570       SAVE
10571
10572       PARAMETER ( LINP = 10 ,
10573      &            LOUT = 6 ,
10574      &            LDAT = 9 )
10575
10576       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10577      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10578
10579       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10580
10581       LOGICAL LSTART
10582
10583       PARAMETER (NSRT=10)
10584       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10585       DIMENSION X(3,260),WD(4),RD(3)
10586
10587       DATA PDIF/0.545D0/,R2MIN/0.16D0/
10588       DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10589       DATA RD /2.09D0, 0.935D0, 0.697D0/
10590
10591       X1SUM = ZERO
10592       X2SUM = ZERO
10593       X3SUM = ZERO
10594
10595       IF (N.EQ.1) THEN
10596          X(1,1) = ZERO
10597          X(2,1) = ZERO
10598          X(3,1) = ZERO
10599       ELSEIF (N.EQ.2) THEN
10600          EPS = DT_RNDM(RD(1))
10601          DO 30 I=1,3
10602             IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10603    30    CONTINUE
10604    40    CONTINUE
10605          DO 50 J=1,3
10606             CALL DT_RANNOR(X1,X2)
10607             X(J,1) = RD(I)*X1
10608             X(J,2) = -X(J,1)
10609    50    CONTINUE
10610       ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10611          SIGMA = R/SQRTWO
10612          LSTART = .TRUE.
10613          CALL DT_RANNOR(X3,X4)
10614          DO 100 I=1,N
10615             CALL DT_RANNOR(X1,X2)
10616             X(1,I) = SIGMA*X1
10617             X(2,I) = SIGMA*X2
10618             IF (LSTART) GOTO 80
10619             X(3,I) = SIGMA*X4
10620             CALL DT_RANNOR(X3,X4)
10621             GOTO 90
10622    80       CONTINUE
10623             X(3,I) = SIGMA*X3
10624    90       CONTINUE
10625             LSTART = .NOT.LSTART
10626             X1SUM = X1SUM+X(1,I)
10627             X2SUM = X2SUM+X(2,I)
10628             X3SUM = X3SUM+X(3,I)
10629   100    CONTINUE
10630          X1SUM = X1SUM/DBLE(N)
10631          X2SUM = X2SUM/DBLE(N)
10632          X3SUM = X3SUM/DBLE(N)
10633          DO 101 I=1,N
10634             X(1,I) = X(1,I)-X1SUM
10635             X(2,I) = X(2,I)-X2SUM
10636             X(3,I) = X(3,I)-X3SUM
10637   101    CONTINUE
10638       ELSE
10639
10640 * maximum nuclear radius for coordinate sampling
10641          RMAX = R+4.605D0*PDIF
10642
10643 * initialize pre-sorting
10644          DO 121 I=1,NSRT
10645             ICSRT(I) = 0
10646   121    CONTINUE
10647          DR = TWO*RMAX/DBLE(NSRT)
10648
10649 * sample coordinates for N nucleons
10650          DO 140 I=1,N
10651   120       CONTINUE
10652             RAD = RMAX*(DT_RNDM(DR))**ONETHI
10653             F   = DT_DENSIT(N,RAD,R)
10654             IF (DT_RNDM(RAD).GT.F) GOTO 120
10655 *   theta, phi uniformly distributed
10656             CT  = ONE-TWO*DT_RNDM(F)
10657             ST  = SQRT((ONE-CT)*(ONE+CT))
10658             CALL DT_DSFECF(SFE,CFE)
10659             X(1,I) = RAD*ST*CFE
10660             X(2,I) = RAD*ST*SFE
10661             X(3,I) = RAD*CT
10662 *   ensure that distance between two nucleons is greater than R2MIN
10663             IF (I.LT.2) GOTO 122
10664             I1 = I-1
10665             DO 130 I2=1,I1
10666                DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10667      &                 (X(3,I)-X(3,I2))**2
10668                IF (DIST2.LE.R2MIN) GOTO 120
10669   130       CONTINUE
10670   122       CONTINUE
10671 *   save index according to z-bin
10672             IDXZ        = INT( (X(3,I)+RMAX)/DR )+1
10673             ICSRT(IDXZ) = ICSRT(IDXZ)+1
10674             IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10675             X1SUM = X1SUM+X(1,I)
10676             X2SUM = X2SUM+X(2,I)
10677             X3SUM = X3SUM+X(3,I)
10678   140    CONTINUE
10679          X1SUM = X1SUM/DBLE(N)
10680          X2SUM = X2SUM/DBLE(N)
10681          X3SUM = X3SUM/DBLE(N)
10682          DO 141 I=1,N
10683             X(1,I) = X(1,I)-X1SUM
10684             X(2,I) = X(2,I)-X2SUM
10685             X(3,I) = X(3,I)-X3SUM
10686   141    CONTINUE
10687
10688       ENDIF
10689
10690       RETURN
10691       END
10692
10693 *$ CREATE DT_DENSIT.FOR
10694 *COPY DT_DENSIT
10695 *
10696 *===densit=============================================================*
10697 *
10698       DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10699
10700       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10701       SAVE
10702
10703       PARAMETER ( LINP = 10 ,
10704      &            LOUT = 6 ,
10705      &            LDAT = 9 )
10706
10707       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10708       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10709      &           PI    = TWOPI/TWO)
10710
10711       DIMENSION R0(18),FNORM(18)
10712       DATA R0 /  ZERO,   ZERO,   ZERO,   ZERO, 2.12D0,
10713      &         2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10714      &         2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10715      &         2.72D0, 2.66D0, 2.79D0/
10716       DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10717      &            .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10718      &            .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10719      &            .1214D+01,.1265D+01,.1318D+01/
10720       DATA PDIF /0.545D0/
10721
10722       DT_DENSIT = ZERO
10723 * shell model
10724       IF (NA.LE.4) THEN
10725          STOP 'DT_DENSIT-0'
10726       ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10727          R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10728          DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10729      &            *EXP(-(R/R1)**2)/FNORM(NA)
10730 * Woods-Saxon
10731       ELSEIF (NA.GT.18) THEN
10732          DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10733       ENDIF
10734
10735       RETURN
10736       END
10737
10738 *$ CREATE DT_RNCLUS.FOR
10739 *COPY DT_RNCLUS
10740 *
10741 *===rnclus=============================================================*
10742 *
10743       DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10744
10745 ************************************************************************
10746 * Nuclear radius for nucleus with mass number N.                       *
10747 * This version dated 26.9.00  is written by S. Roesler                 *
10748 ************************************************************************
10749
10750       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10751       SAVE
10752
10753       PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10754
10755 * nucleon radius
10756       PARAMETER (RNUCLE = 1.12D0)
10757
10758 * nuclear radii for selected nuclei
10759       DIMENSION RADNUC(18)
10760       DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10761      &               2.58D0,2.71D0,2.66D0,2.71D0/
10762
10763       IF (N.LE.18) THEN
10764          IF (RADNUC(N).GT.0.0D0) THEN
10765             DT_RNCLUS = RADNUC(N)
10766          ELSE
10767             DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10768          ENDIF
10769       ELSE
10770          DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10771       ENDIF
10772
10773       RETURN
10774       END
10775
10776 *$ CREATE DT_DENTST.FOR
10777 *COPY DT_DENTST
10778 *
10779 *===dentst=============================================================*
10780 *
10781 C      PROGRAM DT_DENTST
10782       SUBROUTINE DT_DENTST
10783
10784       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10785       SAVE
10786
10787       OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10788       OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10789
10790       RMIN  = 0.0D0
10791       RMAX  = 8.0D0
10792       NBINS = 500.0D0
10793       DR    = (RMAX-RMIN)/DBLE(NBINS)
10794       DO 1 IA=5,18
10795          FMAX = 0.0D0
10796          DO 2 IR=1,NBINS+1
10797             R = RMIN+DBLE(IR-1)*DR
10798             F = DT_DENSIT(IA,R,R)
10799             IF (F.GT.FMAX) FMAX = F
10800             WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10801     2    CONTINUE
10802          WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10803     1 CONTINUE
10804
10805       CLOSE(40)
10806       CLOSE(41)
10807
10808       END
10809
10810 *$ CREATE DT_SHMAKI.FOR
10811 *COPY DT_SHMAKI
10812 *
10813 *===shmaki=============================================================*
10814 *
10815       SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10816
10817 ************************************************************************
10818 * Initialisation of Glauber formalism. This subroutine has to be       *
10819 * called once (in case of target emulsions as often as many different  *
10820 * target nuclei are considered) before events are sampled.             *
10821 *         NA / NCA   mass number/charge of projectile nucleus          *
10822 *         NB / NCB   mass number/charge of target     nucleus          *
10823 *         IJP        identity of projectile (hadrons/leptons/photons)  *
10824 *         PPN        projectile momentum (for projectile nuclei:       *
10825 *                    momentum per nucleon) in target rest system       *
10826 *         MODE = 0   Glauber formalism invoked                         *
10827 *              = 1   fitted results are loaded from data-file          *
10828 *              = 99  NTARG is forced to be 1                           *
10829 *                    (used in connection with GLAUBERI-card only)      *
10830 * This version dated 22.03.96 is based on the original SHMAKI-routine  *
10831 * and revised by S. Roesler.                                           *
10832 ************************************************************************
10833
10834       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10835       SAVE
10836
10837       PARAMETER ( LINP = 10 ,
10838      &            LOUT = 6 ,
10839      &            LDAT = 9 )
10840
10841       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10842      &           THREE=3.0D0)
10843
10844       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10845
10846 * Glauber formalism: parameters
10847       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10848      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10849      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10850      &                NSITEB,NSTATB
10851
10852 * Lorentz-parameters of the current interaction
10853       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10854      &                UMO,PPCM,EPROJ,PPROJ
10855
10856 * properties of photon/lepton projectiles
10857       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10858
10859 * kinematical cuts for lepton-nucleus interactions
10860       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10861      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10862
10863 * Glauber formalism: cross sections
10864       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10865      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10866      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10867      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10868      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10869      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10870      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10871      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10872      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10873      &                BSLOPE,NEBINI,NQBINI
10874
10875 * cuts for variable energy runs
10876       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10877
10878 * nucleon-nucleon event-generator
10879       CHARACTER*8 CMODEL
10880       LOGICAL LPHOIN
10881       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10882
10883 * Glauber formalism: flags and parameters for statistics
10884       LOGICAL LPROD
10885       CHARACTER*8 CGLB
10886       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10887
10888       DATA NTARG,ICOUT,IVEOUT /0,0,0/
10889
10890 C     CALL DT_HISHAD
10891 C     STOP
10892
10893       NTARG = NTARG+1
10894       IF (MODE.EQ.99) NTARG = 1
10895       NIDX = -NTARG
10896       IF (MODE.EQ.-1) NIDX = NTARG
10897
10898       IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10899       IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10900  1000    FORMAT(//,1X,'SHMAKI:    Glauber formalism (Shmakov et. al) -',
10901      &          ' initialization',/,12X,'--------------------------',
10902      &          '-------------------------',/)
10903
10904       IF (MODE.EQ.2) THEN
10905          CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10906          CALL DT_SHFAST(MODE,PPN,IBACK)
10907          STOP ' Glauber pre-initialization done'
10908       ENDIF
10909       IF (MODE.EQ.1) THEN
10910          CALL DT_PROFBI(NA,NB,PPN,NTARG)
10911       ELSE
10912          IBACK = 1
10913          IF (MODE.EQ.3)  CALL DT_SHFAST(MODE,PPN,IBACK)
10914          IF (IBACK.EQ.1) THEN
10915 * lepton-nucleus (variable energy runs)
10916             IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10917      &          (IJP.EQ.10).OR.(IJP.EQ.11))   THEN
10918                IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10919      &            WRITE(LOUT,1002) NB,NCB
10920  1002          FORMAT(1X,'variable energy run:     projectile-id:  7',
10921      &                '    target A/Z: ',I3,' /',I3,/,/,8X,
10922      &                'E_cm (GeV)    Q^2 (GeV^2)',
10923      &                '    Sigma_tot (mb)     Sigma_in (mb)',/,7X,
10924      &                '--------------------------------',
10925      &                '------------------------------')
10926                AECMLO = LOG10(MIN(UMO,ECMLI))
10927                AECMHI = LOG10(MIN(UMO,ECMHI))
10928                IESTEP = NEB-1
10929                DAECM  = (AECMHI-AECMLO)/DBLE(IESTEP)
10930                IF (AECMLO.EQ.AECMHI) IESTEP = 0
10931                DO 1 I=1,IESTEP+1
10932                   ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10933                   IF (Q2HI.GT.0.1D0) THEN
10934                      IF (Q2LI.LT.0.01D0) THEN
10935                         CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10936                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10937      &                     WRITE(LOUT,1003)
10938      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10939                         Q2LI = 0.01D0
10940                         IBIN = 2
10941                      ELSE
10942                         IBIN = 1
10943                      ENDIF
10944                      IQSTEP = NQB-IBIN
10945                      AQ2LO  = LOG10(Q2LI)
10946                      AQ2HI  = LOG10(Q2HI)
10947                      DAQ2   = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10948                      DO 2 J=IBIN,IQSTEP+IBIN
10949                         Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10950                         CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10951                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10952      &                     WRITE(LOUT,1003) ECMNN(I),
10953      &                     Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10954     2                CONTINUE
10955                   ELSE
10956                      CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10957                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10958      &                  WRITE(LOUT,1003)
10959      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10960                   ENDIF
10961  1003             FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10962     1          CONTINUE
10963                IVEOUT = 1
10964             ELSE
10965 * hadron/photon/nucleus-nucleus
10966                IF ((ABS(VAREHI).GT.ZERO).AND.
10967      &             (ABS(VAREHI).GT.ABS(VARELO))) THEN
10968                   IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10969                      WRITE(LOUT,1004) NA,NB,NCB
10970  1004                FORMAT(1X,'variable energy run:    projectile-id:',
10971      &                      I3,'    target A/Z: ',I3,' /',I3,/)
10972                      WRITE(LOUT,1005)
10973  1005                FORMAT('  E_cm (GeV)  E_Lab (GeV)  sig_tot^pp (mb)'
10974      &                      ,'  Sigma_tot (mb)  Sigma_prod (mb)',/,
10975      &                      ' -------------------------------------',
10976      &                      '--------------------------------------')
10977                   ENDIF
10978                   AECMLO = LOG10(VARCLO)
10979                   AECMHI = LOG10(VARCHI)
10980                   IESTEP = NEB-1
10981                   DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10982                   IF (AECMLO.EQ.AECMHI) IESTEP = 0
10983                   DO 3 I=1,IESTEP+1
10984                      ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10985                      AMP = 0.938D0
10986                      AMT = 0.938D0
10987                      AMP2 = AMP**2
10988                      AMT2 = AMT**2
10989                      ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
10990                      PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
10991                      CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
10992                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10993      &                 WRITE(LOUT,1006)
10994      &                 ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10995  1006             FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
10996     3             CONTINUE
10997                   IVEOUT = 1
10998                ELSE
10999                   CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
11000                ENDIF
11001             ENDIF
11002          ENDIF
11003       ENDIF
11004
11005       IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
11006      &    (IOGLB.NE.100)) THEN
11007          WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
11008      &                    BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
11009  1001    FORMAT(38X,'projectile',
11010      &          '      target',/,1X,'Mass number / charge',
11011      &          17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
11012      &          'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
11013      &          'Parameters of elastic scattering amplitude:',/,5X,
11014      &          'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
11015      &          F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
11016      &          'statistics at each b-step',4X,I5,/,/,1X,
11017      &          'Prod. cross section  ',5X,F10.4,' mb',/)
11018       ENDIF
11019
11020       RETURN
11021       END
11022
11023 *$ CREATE DT_PROFBI.FOR
11024 *COPY DT_PROFBI
11025 *
11026 *===profbi=============================================================*
11027 *
11028       SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
11029
11030 ************************************************************************
11031 * Integral over profile function (to be used for impact-parameter      *
11032 * sampling during event generation).                                   *
11033 * Fitted results are used.                                             *
11034 *         NA / NB    mass numbers of proj./target nuclei               *
11035 *         PPN        projectile momentum (for projectile nuclei:       *
11036 *                    momentum per nucleon) in target rest system       *
11037 *         NTARG      index of target material (i.e. kind of nucleus)   *
11038 * This version dated 31.05.95 is revised by S. Roesler                 *
11039 ************************************************************************
11040
11041       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11042       SAVE
11043
11044       PARAMETER ( LINP = 10 ,
11045      &            LOUT = 6 ,
11046      &            LDAT = 9 )
11047
11048       SAVE
11049
11050       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
11051
11052       LOGICAL LSTART
11053       CHARACTER CNAME*80
11054
11055       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11056
11057 * Glauber formalism: parameters
11058       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11059      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11060      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11061      &                NSITEB,NSTATB
11062
11063 * Glauber formalism: cross sections
11064       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11065      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11066      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11067      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11068      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11069      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11070      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11071      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11072      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11073      &                BSLOPE,NEBINI,NQBINI
11074
11075       PARAMETER (NGLMAX=8000)
11076       DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
11077      &          GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
11078
11079       DATA LSTART /.TRUE./
11080
11081       IF (LSTART) THEN
11082 * read fit-parameters from file
11083          OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
11084          I = 0
11085     1    CONTINUE
11086          READ(47,'(A80)') CNAME
11087          IF (CNAME.EQ.'STOP') GOTO 2
11088          I = I+1
11089          READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
11090      &                 GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
11091      &                 GLAFIT(4,I),GLAFIT(5,I)
11092          IF (I+1.GT.NGLMAX) THEN
11093             WRITE(LOUT,1000)
11094  1000       FORMAT(1X,'PROFBI:    warning! array size exceeded - ',
11095      &             'program stopped')
11096             STOP
11097          ENDIF
11098          GOTO 1
11099     2    CONTINUE
11100          NGLPAR = I
11101          LSTART = .FALSE.
11102       ENDIF
11103
11104       NNA = NA
11105       NNB = NB
11106       IF (NA.GT.NB) THEN
11107          NNA = NB
11108          NNB = NA
11109       ENDIF
11110       IDXGLA = 0
11111       DO 3 J=1,NGLPAR
11112          IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
11113             IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
11114             DO 4 K=1,J-1
11115                IPOINT = J-K
11116                IF (J.EQ.NGLPAR) IPOINT = J+1-K
11117                IF ((NNA.GT.NGLIP(IPOINT)).OR.
11118      &             (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
11119                   IF (IPOINT.EQ.1) IPOINT = 0
11120                   NATMP = NGLIP(IPOINT+1)
11121                   IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
11122                      IDXGLA = IPOINT+1
11123                      GOTO 6
11124                   ELSE
11125                      J1BEG = IPOINT+1
11126                      J1END = J
11127 C                    IF (J.EQ.NGLPAR) THEN
11128 C                       J1BEG = IPOINT
11129 C                       J1END = J
11130 C                    ENDIF
11131                      DO 5 J1=J1BEG,J1END
11132                         IF (NGLIP(J1).EQ.NATMP) THEN
11133                            IF (PPN.LT.GLAPPN(J1)) THEN
11134                               IDXGLA = J1
11135                               GOTO 6
11136                            ENDIF
11137                         ELSE
11138                            IDXGLA = J1-1
11139                            GOTO 6
11140                         ENDIF
11141     5                CONTINUE
11142                      IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
11143      &                  IDXGLA = NGLPAR
11144                   ENDIF
11145                ENDIF
11146     4       CONTINUE
11147          ENDIF
11148     3 CONTINUE
11149
11150     6 CONTINUE
11151       IF (IDXGLA.EQ.0) THEN
11152          WRITE(LOUT,1001) NNA,NNB,PPN
11153  1001    FORMAT(1X,'PROFBI:   configuration (NA,NB,PPN = ',
11154      &          2I4,F6.0,') not found ')
11155          STOP
11156       ENDIF
11157
11158 * no interpolation yet available
11159       XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
11160
11161       BSITE(1,1,NTARG,1) = ZERO
11162       DO 10 I=2,NSITEB
11163          XX = DBLE(I)
11164          POLY  = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
11165      &           GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
11166      &           GLAFIT(5,IDXGLA)*XX**4
11167          IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
11168          BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
11169          IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
11170    10 CONTINUE
11171
11172       RETURN
11173       END
11174
11175 *$ CREATE DT_GLAUBE.FOR
11176 *COPY DT_GLAUBE
11177 *
11178 *===glaube=============================================================*
11179 *
11180       SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
11181
11182 ************************************************************************
11183 * Calculation of configuartion of interacting nucleons for one event.  *
11184 *    NB / NB    mass numbers of proj./target nuclei           (input)  *
11185 *    B          impact parameter                              (output) *
11186 *    INTT       total number of wounded nucleons                 "     *
11187 *    INTA / INTB number of wounded nucleons in proj. / target    "     *
11188 *    JS / JT(i) number of collisions proj. / target nucleon i is       *
11189 *                                                   involved  (output) *
11190 *    NIDX       index of projectile/target material            (input) *
11191 *               = -2 call within FLUKA transport calculation           *
11192 * This is an update of the original routine SHMAKO by J.Ranft/HJM      *
11193 * This version dated 22.03.96 is revised by S. Roesler                 *
11194 *                                                                      *
11195 * Last change 27.12.2006 by S. Roesler.                                *
11196 ************************************************************************
11197
11198       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11199       SAVE
11200
11201       PARAMETER ( LINP = 10 ,
11202      &            LOUT = 6 ,
11203      &            LDAT = 9 )
11204
11205       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
11206      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
11207
11208       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11209
11210       PARAMETER ( MAXNCL = 260,
11211
11212      &            MAXVQU = MAXNCL,
11213      &            MAXSQU = 20*MAXVQU,
11214      &            MAXINT = MAXVQU+MAXSQU)
11215
11216 * Glauber formalism: parameters
11217       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11218      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11219      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11220      &                NSITEB,NSTATB
11221
11222 * Glauber formalism: cross sections
11223       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11224      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11225      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11226      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11227      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11228      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11229      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11230      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11231      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11232      &                BSLOPE,NEBINI,NQBINI
11233
11234 * Lorentz-parameters of the current interaction
11235       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
11236      &                UMO,PPCM,EPROJ,PPROJ
11237
11238 * properties of photon/lepton projectiles
11239       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
11240
11241 * Glauber formalism: collision properties
11242       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
11243      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
11244
11245 * Glauber formalism: flags and parameters for statistics
11246       LOGICAL LPROD
11247       CHARACTER*8 CGLB
11248       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11249
11250       DIMENSION JS(MAXNCL),JT(MAXNCL)
11251
11252       NTARG = ABS(NIDX)
11253
11254 * get actual energy from /DTLTRA/
11255       ECMNOW = UMO
11256       Q2     = VIRT
11257 *
11258 * new patch for pre-initialized variable projectile/target/energy runs,
11259 * bypassed for use within FLUKA (Nidx=-2)
11260       IF (IOGLB.EQ.100) THEN
11261          IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
11262 *
11263 * variable energy run, interpolate profile function
11264       ELSE
11265          I1   = 1
11266          I2   = 1
11267          RATE = ONE
11268          IF (NEBINI.GT.1) THEN
11269             IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
11270                I1   = NEBINI
11271                I2   = NEBINI
11272                RATE = ONE
11273             ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
11274                DO 1 I=2,NEBINI
11275                   IF (ECMNOW.LT.ECMNN(I)) THEN
11276                      I1   = I-1
11277                      I2   = I
11278                      RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
11279                      GOTO 2
11280                   ENDIF
11281     1          CONTINUE
11282     2          CONTINUE
11283             ENDIF
11284          ENDIF
11285          J1   = 1
11286          J2   = 1
11287          RATQ = ONE
11288          IF (NQBINI.GT.1) THEN
11289             IF (Q2.GE.Q2G(NQBINI)) THEN
11290                J1   = NQBINI
11291                J2   = NQBINI
11292                RATQ = ONE
11293             ELSEIF (Q2.GT.Q2G(1)) THEN
11294                DO 3 I=2,NQBINI
11295                   IF (Q2.LT.Q2G(I)) THEN
11296                      J1   = I-1
11297                      J2   = I
11298                      RATQ = LOG10(     Q2/MAX(Q2G(J1),TINY14))/
11299      &                      LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11300 C                    RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
11301                      GOTO 4
11302                   ENDIF
11303     3          CONTINUE
11304     4          CONTINUE
11305             ENDIF
11306          ENDIF
11307
11308          DO 5 I=1,KSITEB
11309             BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
11310      &         RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11311      &         RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11312      &         RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
11313      &                    BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
11314     5    CONTINUE
11315       ENDIF
11316
11317       CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
11318       IF (NIDX.LE.-1) THEN
11319          RPROJ = RASH(1)
11320          RTARG = RBSH(NTARG)
11321       ELSE
11322          RPROJ = RASH(NTARG)
11323          RTARG = RBSH(1)
11324       ENDIF
11325
11326       RETURN
11327       END
11328
11329 *$ CREATE DT_DIAGR.FOR
11330 *COPY DT_DIAGR
11331 *
11332 *===diagr==============================================================*
11333 *
11334       SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
11335      &                                                         NIDX)
11336
11337 ************************************************************************
11338 * Based on the original version by Shmakov et al.                      *
11339 * This version dated 21.04.95 is revised by S. Roesler                 *
11340 ************************************************************************
11341
11342       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11343       SAVE
11344
11345       PARAMETER ( LINP = 10 ,
11346      &            LOUT = 6 ,
11347      &            LDAT = 9 )
11348
11349       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
11350       PARAMETER (TWOPI  = 6.283185307179586454D+00,
11351      &           PI     = TWOPI/TWO,
11352      &           GEV2MB = 0.38938D0,
11353      &           GEV2FM = 0.1972D0,
11354      &           ALPHEM = ONE/137.0D0,
11355 * proton mass
11356      &           AMP    = 0.938D0,
11357      &           AMP2   = AMP**2,
11358 * rho0 mass
11359      &           AMRHO0 = 0.77D0)
11360
11361       COMPLEX*16 C,CA,CI
11362
11363       PARAMETER ( MAXNCL = 260,
11364
11365      &            MAXVQU = MAXNCL,
11366      &            MAXSQU = 20*MAXVQU,
11367      &            MAXINT = MAXVQU+MAXSQU)
11368
11369 * particle properties (BAMJET index convention)
11370       CHARACTER*8  ANAME
11371       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11372      &                IICH(210),IIBAR(210),K1(210),K2(210)
11373
11374       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11375
11376 * emulsion treatment
11377       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11378      &                NCOMPO,IEMUL
11379
11380 * Glauber formalism: parameters
11381       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11382      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11383      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11384      &                NSITEB,NSTATB
11385
11386 * Glauber formalism: cross sections
11387       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11388      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11389      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11390      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11391      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11392      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11393      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11394      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11395      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11396      &                BSLOPE,NEBINI,NQBINI
11397
11398 * VDM parameter for photon-nucleus interactions
11399       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11400
11401 * nucleon-nucleon event-generator
11402       CHARACTER*8 CMODEL
11403       LOGICAL LPHOIN
11404       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
11405 **PHOJET105a
11406 C     COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11407 **PHOJET112
11408
11409 C  obsolete cut-off information
11410       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
11411       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11412 **
11413
11414 * coordinates of nucleons
11415       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
11416
11417 * interface between Glauber formalism and DPM
11418       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
11419      &                INTER1(MAXINT),INTER2(MAXINT)
11420
11421 * statistics: Glauber-formalism
11422       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
11423
11424 * n-n cross section fluctuations
11425       PARAMETER (NBINS = 1000)
11426       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
11427
11428       DIMENSION JS(MAXNCL),JT(MAXNCL),
11429      &          JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
11430      &          JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
11431       DIMENSION NWA(0:210),NWB(0:210)
11432
11433       LOGICAL LFIRST
11434       DATA LFIRST /.TRUE./
11435
11436       DATA NTARGO,ICNT /0,0/
11437
11438       NTARG = ABS(NIDX)
11439
11440       IF (LFIRST) THEN
11441          LFIRST = .FALSE.
11442          IF (NCOMPO.EQ.0) THEN
11443             NCALL  = 0
11444             NWAMAX = NA
11445             NWBMAX = NB
11446             DO 17 I=0,210
11447                NWA(I) = 0
11448                NWB(I) = 0
11449    17       CONTINUE
11450          ENDIF
11451       ENDIF
11452       IF (NTARG.EQ.-1) THEN
11453          IF (NCOMPO.EQ.0) THEN
11454             WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
11455             WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
11456      &                                NCALL,NWAMAX,NWBMAX
11457             DO 18 I=1,MAX(NWAMAX,NWBMAX)
11458                WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
11459      &                          I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
11460      &                            NWB(I),DBLE(NWB(I))/DBLE(NCALL)
11461    18       CONTINUE
11462          ENDIF
11463          RETURN
11464       ENDIF
11465
11466       DCOH   = 1.0D10
11467       IPNT   = 0
11468
11469       SQ2  = Q2
11470       IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
11471       S   = ECMNOW**2
11472       X   = SQ2/(S+SQ2-AMP2)
11473       XNU = (S+SQ2-AMP2)/(TWO*AMP)
11474 * photon projectiles: recalculate photon-nucleon amplitude
11475       IF (IJPROJ.EQ.7) THEN
11476    15    CONTINUE
11477 *  VDM assumption: mass of V-meson
11478          AMV2   = DT_SAM2(SQ2,ECMNOW)
11479          AMV    = SQRT(AMV2)
11480          IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
11481 *  check for pointlike interaction
11482          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
11483 **sr 27.10.
11484 C        SIGSH  = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11485          SIGSH  = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11486 **
11487          ROSH   = 0.1D0
11488          BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
11489      &                   +0.25D0*LOG(S/(AMV2+SQ2)))
11490 *  coherence length
11491          IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
11492       ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
11493          IF (MCGENE.EQ.2) THEN
11494             ZERO1 = ZERO
11495             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
11496      &                                                BSLOPE,0)
11497          ELSE
11498             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
11499          ENDIF
11500          IF (ECMNOW.LE.3.0D0) THEN
11501             ROSH = -0.43D0
11502          ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
11503             ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
11504          ELSEIF (ECMNOW.GT.50.0D0) THEN
11505             ROSH = 0.1D0
11506          ENDIF
11507          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11508          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11509          IF (MCGENE.EQ.2) THEN
11510             ZERO1 = ZERO
11511             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
11512      &                                                  BDUM,0)
11513             SIGSH = SIGSH/10.0D0
11514          ELSE
11515 C           SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11516             DUMZER = ZERO
11517             CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11518             SIGSH = SIGSH/10.0D0
11519          ENDIF
11520       ELSE
11521          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
11522          ROSH   = 0.01D0
11523          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11524          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11525 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11526          DUMZER = ZERO
11527          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11528          SIGSH = SIGSH/10.0D0
11529       ENDIF
11530       GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
11531       GAM = GSH
11532       RCA = GAM*SIGSH/TWOPI
11533       FCA = -ROSH*RCA
11534       CA  = DCMPLX(RCA,FCA)
11535       CI  = DCMPLX(ONE,ZERO)
11536
11537    16 CONTINUE
11538 * impact parameter
11539       IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11540
11541       NTRY = 0
11542     3 CONTINUE
11543       NTRY = NTRY+1
11544 * initializations
11545       JNT  = 0
11546       DO 1 I=1,NA
11547          JS(I) = 0
11548     1 CONTINUE
11549       DO 2 I=1,NB
11550          JT(I) = 0
11551     2 CONTINUE
11552       IF (IJPROJ.EQ.7) THEN
11553          DO 8 I=1,MAXNCL
11554             JS0(I) = 0
11555             JNT0(I)= 0
11556             DO 9 J=1,NB
11557                JT0(I,J) = 0
11558     9       CONTINUE
11559     8    CONTINUE
11560       ENDIF
11561
11562 * nucleon configuration
11563 C     IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11564       IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11565 C        CALL DT_CONUCL(PKOO,NA,RASH,2)
11566 C        CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11567          IF (NIDX.LE.-1) THEN
11568             CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11569             CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11570          ELSE
11571             CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11572             CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11573          ENDIF
11574          NTARGO = NTARG
11575       ENDIF
11576       ICNT = ICNT+1
11577
11578 * LEPTO: pick out one struck nucleon
11579       IF (MCGENE.EQ.3) THEN
11580          JNT     = 1
11581          JS(1)   = 1
11582          IDX     = INT(DT_RNDM(X)*NB)+1
11583          JT(IDX) = 1
11584          B       = ZERO
11585          GOTO 19
11586       ENDIF
11587
11588       DO 4 INA=1,NA
11589 * cross section fluctuations
11590          AFLUC = ONE
11591          IF (IFLUCT.EQ.1) THEN
11592             IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11593             AFLUC = FLUIXX(IFLUK)
11594          ENDIF
11595          KK1  = 1
11596          KINT = 1
11597          DO 5 INB=1,NB
11598 * photon-projectile: check for supression by coherence length
11599             IF (IJPROJ.EQ.7) THEN
11600                IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11601                   KK1  = INB
11602                   KINT = KINT+1
11603                ENDIF
11604             ENDIF
11605             QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11606             QQ2 =   TKOO(2,INB)-PKOO(2,INA)
11607             XY  = GAM*(QQ1*QQ1+QQ2*QQ2)
11608             IF (XY.LE.15.0D0) THEN
11609                C  = CI-CA*AFLUC*EXP(-XY)
11610                AR = DBLE(C)
11611                AI = DIMAG(C)
11612                P  = AR*AR+AI*AI
11613                IF (DT_RNDM(XY).GE.P) THEN
11614                   JNT = JNT+1
11615                   IF (IJPROJ.EQ.7) THEN
11616                      JNT0(KINT) = JNT0(KINT)+1
11617                      IF (JNT0(KINT).GT.MAXNCL) THEN
11618                         WRITE(LOUT,1001) MAXNCL
11619  1001                   FORMAT(1X,
11620      &                        'DIAGR:  no. of requested interactions',
11621      &                        ' exceeds array dimensions ',I4)
11622                         STOP
11623                      ENDIF
11624                      JS0(KINT)      = JS0(KINT)+1
11625                      JT0(KINT,INB)  = JT0(KINT,INB)+1
11626                      JI1(KINT,JNT0(KINT)) = INA
11627                      JI2(KINT,JNT0(KINT)) = INB
11628                   ELSE
11629                      IF (JNT.GT.MAXINT) THEN
11630                         WRITE(LOUT,1000) JNT, MAXINT
11631  1000                   FORMAT(1X,
11632      &                        'DIAGR:  no. of requested interactions ('
11633      &                        ,I4,') exceeds array dimensions (',I4,')')
11634                         STOP
11635                      ENDIF
11636                      JS(INA) = JS(INA)+1
11637                      JT(INB) = JT(INB)+1
11638                      INTER1(JNT) = INA
11639                      INTER2(JNT) = INB
11640                   ENDIF
11641                ENDIF
11642             ENDIF
11643     5    CONTINUE
11644     4 CONTINUE
11645
11646       IF (JNT.EQ.0) THEN
11647          IF (NTRY.LT.500) THEN
11648             GOTO 3
11649          ELSE
11650 C           WRITE(6,*) ' new impact parameter required (old= ',B,')'
11651             GOTO 16
11652          ENDIF
11653       ENDIF
11654
11655       IDIREC = 0
11656       IF (IJPROJ.EQ.7) THEN
11657          K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11658    10    CONTINUE
11659          IF (JNT0(K).EQ.0) THEN
11660             K = K+1
11661             IF (K.GT.KINT) K = 1
11662             GOTO 10
11663          ENDIF
11664 * supress Glauber-cascade by direct photon processes
11665          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11666          IF (IPNT.GT.0) THEN
11667             JNT   = 1
11668             JS(1) = 1
11669             DO 11 INB=1,NB
11670                JT(INB) = JT0(K,INB)
11671                IF (JT(INB).GT.0) GOTO 12
11672    11       CONTINUE
11673    12       CONTINUE
11674             INTER1(1) = 1
11675             INTER2(1) = INB
11676             IDIREC    = IPNT
11677          ELSE
11678             JNT   = JNT0(K)
11679             JS(1) = JS0(K)
11680             DO 13 INB=1,NB
11681                JT(INB) = JT0(K,INB)
11682    13       CONTINUE
11683             DO 14 I=1,JNT
11684                INTER1(I) = JI1(K,I)
11685                INTER2(I) = JI2(K,I)
11686    14       CONTINUE
11687          ENDIF
11688       ENDIF
11689
11690    19 CONTINUE
11691       INTA = 0
11692       INTB = 0
11693       DO 6 I=1,NA
11694         IF (JS(I).NE.0) INTA=INTA+1
11695     6 CONTINUE
11696       DO 7 I=1,NB
11697         IF (JT(I).NE.0) INTB=INTB+1
11698     7 CONTINUE
11699       ICWPG = INTA
11700       ICWTG = INTB
11701       ICIG  = JNT
11702       IPGLB = IPGLB+INTA
11703       ITGLB = ITGLB+INTB
11704       NGLB = NGLB+1
11705
11706       IF (NCOMPO.EQ.0) THEN
11707          NCALL = NCALL+1
11708          NWA(INTA) = NWA(INTA)+1
11709          NWB(INTB) = NWB(INTB)+1
11710       ENDIF
11711
11712       RETURN
11713       END
11714
11715 *$ CREATE DT_MODB.FOR
11716 *COPY DT_MODB
11717 *
11718 *===modb===============================================================*
11719 *
11720       SUBROUTINE DT_MODB(B,NIDX)
11721
11722 ************************************************************************
11723 * Sampling of impact parameter of collision.                           *
11724 *    B          impact parameter    (output)                           *
11725 *    NIDX       index of projectile/target material             (input)*
11726 * Based on the original version by Shmakov et al.                      *
11727 * This version dated 21.04.95 is revised by S. Roesler                 *
11728 *                                                                      *
11729 * Last change 27.12.2006 by S. Roesler.                                *
11730 ************************************************************************
11731
11732       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11733       SAVE
11734
11735       PARAMETER ( LINP = 10 ,
11736      &            LOUT = 6 ,
11737      &            LDAT = 9 )
11738
11739       PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11740
11741       LOGICAL LEFT,LFIRST
11742
11743 * central particle production, impact parameter biasing
11744       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11745
11746       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11747
11748 * Glauber formalism: parameters
11749       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11750      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11751      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11752      &                NSITEB,NSTATB
11753
11754 * Glauber formalism: cross sections
11755       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11756      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11757      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11758      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11759      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11760      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11761      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11762      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11763      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11764      &                BSLOPE,NEBINI,NQBINI
11765
11766       DATA LFIRST /.TRUE./
11767
11768       NTARG = ABS(NIDX)
11769       IF (NIDX.LE.-1) THEN
11770          RA = RASH(1)
11771          RB = RBSH(NTARG)
11772       ELSE
11773          RA = RASH(NTARG)
11774          RB = RBSH(1)
11775       ENDIF
11776
11777       IF (ICENTR.EQ.2) THEN
11778          IF (RA.EQ.RB) THEN
11779             BB = DT_RNDM(B)*(0.3D0*RA)**2
11780             B  = SQRT(BB)
11781          ELSEIF(RA.LT.RB)THEN
11782             BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11783             B  = SQRT(BB)
11784          ELSEIF(RA.GT.RB)THEN
11785             BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11786             B  = SQRT(BB)
11787          ENDIF
11788       ELSE
11789     9    CONTINUE
11790          Y  = DT_RNDM(BB)
11791          I0 = 1
11792          I2 = NSITEB
11793    10    CONTINUE
11794          I1 = (I0+I2)/2
11795          LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11796      &          *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11797          IF (LEFT) GOTO 20
11798          I0 = I1
11799          GOTO 30
11800    20    CONTINUE
11801          I2 = I1
11802    30    CONTINUE
11803          IF (I2-I0-2) 40,50,60
11804    40    CONTINUE
11805          I1 = I2+1
11806          IF (I1.GT.NSITEB) I1 = I0-1
11807          GOTO 70
11808    50    CONTINUE
11809          I1 = I0+1
11810          GOTO 70
11811    60    CONTINUE
11812          GOTO 10
11813    70    CONTINUE
11814          X0 = DBLE(I0-1)*BSTEP(NTARG)
11815          X1 = DBLE(I1-1)*BSTEP(NTARG)
11816          X2 = DBLE(I2-1)*BSTEP(NTARG)
11817          Y0 = BSITE(0,1,NTARG,I0)
11818          Y1 = BSITE(0,1,NTARG,I1)
11819          Y2 = BSITE(0,1,NTARG,I2)
11820    80    CONTINUE
11821          B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11822      &       X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11823      &       X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11824 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11825          B = B+0.5D0*BSTEP(NTARG)
11826          IF (B.LT.ZERO) B = X1
11827          IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11828          IF (ICENTR.LT.0) THEN
11829             IF (LFIRST) THEN
11830                LFIRST = .FALSE.
11831                IF (ICENTR.LE.-100) THEN
11832                   BIMIN  = 0.0D0
11833                ELSE
11834                   XSFRAC = 0.0D0
11835                ENDIF
11836                CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11837                WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11838      &                          BIMIN,BIMAX,XSFRAC*100.0D0,
11839      &                          XSFRAC*XSPRO(1,1,NTARG)
11840  10000         FORMAT(/,1X,'DT_MODB:      Biasing in impact parameter',
11841      &                /,15X,'---------------------------'/,/,4X,
11842      &                'average radii of proj / targ :',F10.3,' fm /',
11843      &                F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11844      &                F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11845      &                F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11846      &                ' cross section :',F10.3,' %',/,5X,
11847      &                'corresponding cross section :',F10.3,' mb',/)
11848             ENDIF
11849             IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11850                B = BIMIN
11851             ELSE
11852                IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11853             ENDIF
11854          ENDIF
11855       ENDIF
11856
11857       RETURN
11858       END
11859
11860 *$ CREATE DT_SHFAST.FOR
11861 *COPY DT_SHFAST
11862 *
11863 *===shfast=============================================================*
11864 *
11865       SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11866
11867       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11868       SAVE
11869
11870       PARAMETER ( LINP = 10 ,
11871      &            LOUT = 6 ,
11872      &            LDAT = 9 )
11873
11874       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11875      &           ONE=1.0D0,TWO=2.0D0)
11876
11877       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11878
11879 * Glauber formalism: parameters
11880       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11881      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11882      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11883      &                NSITEB,NSTATB
11884
11885 * properties of interacting particles
11886       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11887
11888 * Glauber formalism: cross sections
11889       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11890      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11891      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11892      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11893      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11894      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11895      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11896      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11897      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11898      &                BSLOPE,NEBINI,NQBINI
11899
11900       IBACK = 0
11901
11902       IF (MODE.EQ.2) THEN
11903          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11904          WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11905  1000    FORMAT(1X,8I5,E15.5)
11906          WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11907  1001    FORMAT(1X,4E15.5)
11908          WRITE(47,1002) SIGSH,ROSH,GSH
11909  1002    FORMAT(1X,3E15.5)
11910          DO 10 I=1,100
11911             WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11912    10    CONTINUE
11913          WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11914  1003    FORMAT(1X,2I10,3E15.5)
11915          CLOSE(47)
11916       ELSE
11917          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11918          READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11919          IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11920      &       (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11921      &       .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11922      &       (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11923             READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11924             READ(47,1002) SIGSH,ROSH,GSH
11925             DO 11 I=1,100
11926                READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11927    11       CONTINUE
11928             READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11929          ELSE
11930             IBACK = 1
11931          ENDIF
11932          CLOSE(47)
11933       ENDIF
11934
11935       RETURN
11936       END
11937
11938 *$ CREATE DT_POILIK.FOR
11939 *COPY DT_POILIK
11940 *
11941 *===poilik=============================================================*
11942 *
11943       SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11944
11945       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11946       SAVE
11947
11948       PARAMETER ( LINP = 10 ,
11949      &            LOUT = 6 ,
11950      &            LDAT = 9 )
11951
11952       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11953       PARAMETER (NE = 8)
11954
11955 **PHOJET105a
11956 C     CHARACTER*8 MDLNA
11957 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11958 C     PARAMETER (IEETAB=10)
11959 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11960 **PHOJET110
11961
11962 C  model switches and parameters
11963       CHARACTER*8 MDLNA
11964       INTEGER ISWMDL,IPAMDL
11965       DOUBLE PRECISION PARMDL
11966       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11967
11968 C  energy-interpolation table
11969       INTEGER IEETA2
11970       PARAMETER ( IEETA2 = 20 )
11971       INTEGER ISIMAX
11972       DOUBLE PRECISION SIGTAB,SIGECM
11973       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11974 **
11975
11976 * VDM parameter for photon-nucleus interactions
11977       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11978 **sr 22.7.97
11979
11980       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11981
11982 * Glauber formalism: cross sections
11983       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11984      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11985      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11986      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11987      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11988      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11989      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11990      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11991      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11992      &                BSLOPE,NEBINI,NQBINI
11993 **
11994
11995       DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
11996
11997       IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
11998
11999 * load cross sections from interpolation table
12000       IP = 1
12001       IF(ECM.LE.SIGECM(IP,1)) THEN
12002         I1 = 1
12003         I2 = 1
12004       ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
12005         DO 50 I=2,ISIMAX
12006           IF(ECM.LE.SIGECM(IP,I)) GOTO 200
12007   50    CONTINUE
12008  200    CONTINUE
12009         I1 = I-1
12010         I2 = I
12011       ELSE
12012         WRITE(LOUT,'(/1X,A,2E12.3)')
12013      &    'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
12014         I1 = ISIMAX
12015         I2 = ISIMAX
12016       ENDIF
12017       FAC2 = ZERO
12018       IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
12019      &                     /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
12020       FAC1 = ONE-FAC2
12021
12022       SIGANO = DT_SANO(ECM)
12023
12024 * cross section dependence on photon virtuality
12025       FSUP1 = ZERO
12026       DO  150 I=1,3
12027          FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
12028      &                             /(ONE+VIRT/PARMDL(30+I))**2
12029  150  CONTINUE
12030       FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
12031       FAC1  = FAC1*FSUP1
12032       FAC2  = FAC2*FSUP1
12033       FSUP2 = ONE
12034
12035       ECMOLD = ECM
12036       Q2OLD  = VIRT
12037
12038     3 CONTINUE
12039
12040 C     SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
12041       CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
12042       IF (ISHAD(1).EQ.1) THEN
12043          SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
12044       ELSE
12045          SIGDIR = ZERO
12046       ENDIF
12047       SIGANO = FSUP1*FSUP2*SIGANO
12048       SIGTOT = SIGTOT-SIGDIR-SIGANO
12049       SIGDIR = SIGDIR/(FSUP1*FSUP2)
12050       SIGANO = SIGANO/(FSUP1*FSUP2)
12051       SIGTOT = SIGTOT+SIGDIR+SIGANO
12052
12053       RR = DT_RNDM(SIGTOT)
12054       IF (RR.LT.SIGDIR/SIGTOT) THEN
12055          IPNT = 1
12056       ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
12057      &        (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
12058          IPNT = 2
12059       ELSE
12060          IPNT = 0
12061       ENDIF
12062       RPNT = (SIGDIR+SIGANO)/SIGTOT
12063 C     WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
12064 C     WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
12065 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
12066 C     WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
12067       IF (MODE.EQ.1) RETURN
12068
12069 **sr 22.7.97
12070       K1   = 1
12071       K2   = 1
12072       RATE = ZERO
12073       IF (ECM.GE.ECMNN(NEBINI)) THEN
12074          K1   = NEBINI
12075          K2   = NEBINI
12076          RATE = ONE
12077       ELSEIF (ECM.GT.ECMNN(1)) THEN
12078          DO 10 I=2,NEBINI
12079             IF (ECM.LT.ECMNN(I)) THEN
12080                K1   = I-1
12081                K2   = I
12082                RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
12083                GOTO 11
12084             ENDIF
12085    10    CONTINUE
12086    11    CONTINUE
12087       ENDIF
12088       J1   = 1
12089       J2   = 1
12090       RATQ = ZERO
12091       IF (NQBINI.GT.1) THEN
12092          IF (VIRT.GE.Q2G(NQBINI)) THEN
12093             J1   = NQBINI
12094             J2   = NQBINI
12095             RATQ = ONE
12096          ELSEIF (VIRT.GT.Q2G(1)) THEN
12097             DO 12 I=2,NQBINI
12098                IF (VIRT.LT.Q2G(I)) THEN
12099                   J1   = I-1
12100                   J2   = I
12101                   RATQ = LOG10(   VIRT/MAX(Q2G(J1),TINY14))/
12102      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
12103                   GOTO 13
12104                ENDIF
12105    12       CONTINUE
12106    13       CONTINUE
12107          ENDIF
12108       ENDIF
12109       SGA = XSPRO(K1,J1,NTARG)+
12110      &      RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
12111      &      RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
12112      &      RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
12113      &                 XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
12114       SDI = DBLE(NB)*SIGDIR
12115       SAN = DBLE(NB)*SIGANO
12116       SPL = SDI+SAN
12117       RR = DT_RNDM(SPL)
12118       IF (RR.LT.SDI/SGA) THEN
12119          IPNT = 1
12120       ELSEIF ((RR.GE.SDI/SGA).AND.
12121      &        (RR.LT.SPL/SGA)) THEN
12122          IPNT = 2
12123       ELSE
12124          IPNT = 0
12125       ENDIF
12126       RPNT = SPL/SGA
12127 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
12128 **
12129
12130       RETURN
12131       END
12132
12133 *$ CREATE DT_GLBINI.FOR
12134 *COPY DT_GLBINI
12135 *
12136 *===glbini=============================================================*
12137 *
12138       SUBROUTINE DT_GLBINI(WHAT)
12139
12140 ************************************************************************
12141 * Pre-initialization of profile function                               *
12142 * This version dated 28.11.00 is written by S. Roesler.                *
12143 *                                                                      *
12144 * Last change 27.12.2006 by S. Roesler.                                *
12145 ************************************************************************
12146
12147       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12148       SAVE
12149
12150       PARAMETER ( LINP = 10 ,
12151      &            LOUT = 6 ,
12152      &            LDAT = 9 )
12153
12154       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
12155
12156       LOGICAL LCMS
12157
12158 * particle properties (BAMJET index convention)
12159       CHARACTER*8  ANAME
12160       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12161      &                IICH(210),IIBAR(210),K1(210),K2(210)
12162
12163 * properties of interacting particles
12164       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12165
12166       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12167
12168 * emulsion treatment
12169       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12170      &                NCOMPO,IEMUL
12171
12172 * Glauber formalism: flags and parameters for statistics
12173       LOGICAL LPROD
12174       CHARACTER*8 CGLB
12175       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12176
12177 * number of data sets other than protons and nuclei
12178 * at the moment = 2 (pions and kaons)
12179       PARAMETER (MAXOFF=2)
12180       DIMENSION IJPINI(5),IOFFST(25)
12181       DATA IJPINI / 13, 15,  0,  0,  0/
12182 * Glauber data-set to be used for hadron projectiles
12183 * (0=proton, 1=pion, 2=kaon)
12184       DATA (IOFFST(K),K=1,25) /
12185      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12186      &  0, 0, 1, 2, 2/
12187 * Acceptance interval for target nucleus mass
12188       PARAMETER (KBACC = 6)
12189
12190 * flags for input different options
12191       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12192       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12193      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12194
12195       PARAMETER (MAXMSS = 100)
12196       DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
12197       DIMENSION WHAT(6)
12198
12199       DATA JPEACH,JPSTEP / 18, 5 /
12200
12201 * temporary patch until fix has been implemented in phojet:
12202 *  maximum energy for pion projectile
12203       DATA ECMXPI / 100000.0D0 /
12204 *
12205 *--------------------------------------------------------------------------
12206 * general initializations
12207 *
12208 *  steps in projectile mass number for initialization
12209       IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
12210       IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
12211 *
12212 *  energy range and binning
12213       ELO  = ABS(WHAT(1))
12214       EHI  = ABS(WHAT(2))
12215       IF (ELO.GT.EHI) ELO = EHI
12216       NEBIN = MAX(INT(WHAT(3)),1)
12217       IF (ELO.EQ.EHI) NEBIN = 0
12218       LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
12219       IF (LCMS) THEN
12220          ECMINI = EHI
12221       ELSE
12222          ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
12223      &                 +2.0D0*AAM(IJTARG)*EHI)
12224       ENDIF
12225 *
12226 *  default arguments for Glauber-routine
12227       XI  = ZERO
12228       Q2I = ZERO
12229 *
12230 *  initialize nuclear parameters, etc.
12231
12232 *  initialize evaporation if the code is not used as Fluka event generator
12233       IF (ITRSPT.NE.1) THEN
12234          CALL NCDTRD
12235          CALL INCINI
12236       ENDIF
12237
12238 *
12239 *  open Glauber-data output file
12240       IDX = INDEX(CGLB,' ')
12241       K   = 12
12242       IF (IDX.GT.1) K = IDX-1
12243       OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12244 *
12245 *--------------------------------------------------------------------------
12246 * Glauber-initialization for proton and nuclei projectiles
12247 *
12248 *  initialize phojet for proton-proton interactions
12249       ELAB = ZERO
12250       PLAB = ZERO
12251       CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12252       CALL DT_PHOINI
12253 *
12254 *  record projectile masses
12255       NASAV = 0
12256       NPROJ = MIN(IP,JPEACH)
12257       DO 10 KPROJ=1,NPROJ
12258          NASAV = NASAV+1
12259          IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12260          IASAV(NASAV) = KPROJ
12261    10 CONTINUE
12262       IF (IP.GT.JPEACH) THEN
12263          NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
12264          IF (NPROJ.EQ.0) THEN
12265             NASAV = NASAV+1
12266             IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12267             IASAV(NASAV) = IP
12268          ELSE
12269             DO 11 IPROJ=1,NPROJ
12270                KPROJ = JPEACH+IPROJ*JPSTEP
12271                NASAV = NASAV+1
12272                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12273                IASAV(NASAV) = KPROJ
12274    11       CONTINUE
12275             IF (KPROJ.LT.IP) THEN
12276                NASAV = NASAV+1
12277                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12278                IASAV(NASAV) = IP
12279             ENDIF
12280          ENDIF
12281       ENDIF
12282 *
12283 *  record target masses
12284       NBSAV = 0
12285       NTARG = 1
12286       IF (NCOMPO.GT.0) NTARG = NCOMPO
12287       DO 12 ITARG=1,NTARG
12288          NBSAV = NBSAV+1
12289          IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
12290          IF (NCOMPO.GT.0) THEN
12291             IBSAV(NBSAV) = IEMUMA(ITARG)
12292          ELSE
12293             IBSAV(NBSAV) = IT
12294          ENDIF
12295    12 CONTINUE
12296 *
12297 *  print masses
12298       WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
12299  1000 FORMAT(I4,A,1P,2E13.5)
12300       NLINES = DBLE(NASAV)/18.0D0
12301       IF (NLINES.GT.0) THEN
12302          DO 13 I=1,NLINES
12303             IF (I.EQ.1) THEN
12304                WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
12305             ELSE
12306                WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
12307             ENDIF
12308    13    CONTINUE
12309       ENDIF
12310       I0 = 18*NLINES+1
12311       IF (I0.LE.NASAV) THEN
12312          IF (I0.EQ.1) THEN
12313             WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
12314          ELSE
12315             WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
12316          ENDIF
12317       ENDIF
12318       NLINES = DBLE(NBSAV)/18.0D0
12319       IF (NLINES.GT.0) THEN
12320          DO 14 I=1,NLINES
12321             IF (I.EQ.1) THEN
12322                WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
12323             ELSE
12324                WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
12325             ENDIF
12326    14    CONTINUE
12327       ENDIF
12328       I0 = 18*NLINES+1
12329       IF (I0.LE.NBSAV) THEN
12330          IF (I0.EQ.1) THEN
12331             WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
12332          ELSE
12333             WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
12334          ENDIF
12335       ENDIF
12336 *
12337 *  calculate Glauber-data for each energy and mass combination
12338 *
12339 *   loop over energy bins
12340       ELO = LOG10(ELO)
12341       EHI = LOG10(EHI)
12342       DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
12343       DO 1 IE=1,NEBIN+1
12344          E = ELO+DBLE(IE-1)*DEBIN
12345          E = 10**E
12346          IF (LCMS) THEN
12347             E   = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
12348             ECM = E
12349          ELSE
12350             PLAB = ZERO
12351             ECM  = ZERO
12352             E    = MAX(AAM(IJPROJ)+0.1D0,E)
12353             CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12354          ENDIF
12355 *
12356 *   loop over projectile and target masses
12357          DO 2 ITARG=1,NBSAV
12358             DO 3 IPROJ=1,NASAV
12359                CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
12360      &                                       XI,Q2I,ECM,1,1,-1)
12361     3       CONTINUE
12362     2    CONTINUE
12363 *
12364     1 CONTINUE
12365 *
12366 *--------------------------------------------------------------------------
12367 * Glauber-initialization for pion, kaon, ... projectiles
12368 *
12369       DO 6 IJ=1,MAXOFF
12370 *
12371 *  initialize phojet for this interaction
12372          ELAB = ZERO
12373          PLAB = ZERO
12374          IJPROJ = IJPINI(IJ)
12375          IP     = 1
12376          IPZ    = 1
12377 *
12378 *   temporary patch until fix has been implemented in phojet:
12379          IF (ECMINI.GT.ECMXPI) THEN
12380             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
12381          ELSE
12382             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12383          ENDIF
12384          CALL DT_PHOINI
12385 *
12386 *  calculate Glauber-data for each energy and mass combination
12387 *
12388 *   loop over energy bins
12389          DO 4 IE=1,NEBIN+1
12390             E = ELO+DBLE(IE-1)*DEBIN
12391             E = 10**E
12392             IF (LCMS) THEN
12393                E   = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
12394                ECM = E
12395             ELSE
12396                PLAB = ZERO
12397                ECM  = ZERO
12398                E    = MAX(AAM(IJPROJ)+TINY14,E)
12399                CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12400             ENDIF
12401 *
12402 *   loop over projectile and target masses
12403             DO 5 ITARG=1,NBSAV
12404                CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
12405     5       CONTINUE
12406 *
12407     4    CONTINUE
12408 *
12409     6 CONTINUE
12410
12411 *--------------------------------------------------------------------------
12412 * close output unit(s), etc.
12413 *
12414       CLOSE(LDAT)
12415
12416       RETURN
12417       END
12418
12419 *$ CREATE DT_GLBSET.FOR
12420 *COPY DT_GLBSET
12421 *
12422 *===glbset=============================================================*
12423 *
12424       SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
12425 ************************************************************************
12426 * Interpolation of pre-initialized profile functions                   *
12427 * This version dated 28.11.00 is written by S. Roesler.                *
12428 ************************************************************************
12429
12430       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12431       SAVE
12432
12433       PARAMETER ( LINP = 10 ,
12434      &            LOUT = 6 ,
12435      &            LDAT = 9 )
12436
12437       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
12438
12439       LOGICAL LCMS,LREAD,LFRST1,LFRST2
12440
12441 * particle properties (BAMJET index convention)
12442       CHARACTER*8  ANAME
12443       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12444      &                IICH(210),IIBAR(210),K1(210),K2(210)
12445
12446 * Glauber formalism: flags and parameters for statistics
12447       LOGICAL LPROD
12448       CHARACTER*8 CGLB
12449       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12450
12451       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12452
12453 * Glauber formalism: parameters
12454       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
12455      &                BMAX(NCOMPX),BSTEP(NCOMPX),
12456      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
12457      &                NSITEB,NSTATB
12458
12459 * Glauber formalism: cross sections
12460       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
12461      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
12462      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
12463      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
12464      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
12465      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12466      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12467      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12468      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12469      &                BSLOPE,NEBINI,NQBINI
12470
12471 * number of data sets other than protons and nuclei
12472 * at the moment = 2 (pions and kaons)
12473       PARAMETER (MAXOFF=2)
12474       DIMENSION IJPINI(5),IOFFST(25)
12475       DATA IJPINI / 13, 15,  0,  0,  0/
12476 * Glauber data-set to be used for hadron projectiles
12477 * (0=proton, 1=pion, 2=kaon)
12478       DATA (IOFFST(K),K=1,25) /
12479      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12480      &  0, 0, 1, 2, 2/
12481 * Acceptance interval for target nucleus mass
12482       PARAMETER (KBACC = 6)
12483
12484 * emulsion treatment
12485       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12486      &                NCOMPO,IEMUL
12487
12488       PARAMETER (MAXSET=5000,
12489      &           MAXBIN=100)
12490       DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
12491       DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
12492      &          BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
12493      &          IAIDX(10)
12494
12495       DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
12496 *
12497 * read data from file
12498 *
12499       IF (MODE.EQ.0) THEN
12500
12501          IF (LREAD) RETURN
12502
12503          DO 1 I=1,MAXSET
12504             DO 2 J=1,6
12505                XSIG(I,J) = ZERO
12506                XERR(I,J) = ZERO
12507     2       CONTINUE
12508             DO 3 J=1,KSITEB
12509                BPROFL(I,J) = ZERO
12510     3       CONTINUE
12511     1    CONTINUE
12512          DO 4 I=1,MAXBIN
12513             IABIN(I) = 0
12514             IBBIN(I) = 0
12515     4    CONTINUE
12516          DO 5 I=1,KSITEB
12517             BPRO0(I) = ZERO
12518             BPRO1(I) = ZERO
12519             BPRO(I)  = ZERO
12520     5    CONTINUE
12521
12522          IDX = INDEX(CGLB,' ')
12523          K   = 12
12524          IF (IDX.GT.1) K = IDX-1
12525          OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12526          WRITE(LOUT,1000) CGLB(1:K)//'.glb'
12527  1000    FORMAT(/,' GLBSET: impact parameter distributions read from ',
12528      &          'file ',A12,/)
12529 *
12530 *  read binning information
12531          READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
12532 *  return lower energy threshold to Fluka-interface
12533          ELAB = ELO
12534          LCMS = ELO.LT.ZERO
12535          WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
12536          IF (LCMS) THEN
12537             WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
12538          ELSE
12539             WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
12540          ENDIF
12541  1001    FORMAT(2X,A5,'  E_lo = ',1P,E9.3,'  E_hi = ',1P,E9.3,4X,
12542      &          'No. of bins:',I5,/)
12543          ELO  = LOG10(ABS(ELO))
12544          EHI  = LOG10(ABS(EHI))
12545          DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
12546          WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
12547          READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
12548          IF (NABIN.LT.18) THEN
12549             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
12550          ELSE
12551             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
12552          ENDIF
12553          IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
12554          IF (NABIN.GT.18) THEN
12555             NLINES = DBLE(NABIN-18)/18.0D0
12556             IF (NLINES.GT.0) THEN
12557                DO 7 I=1,NLINES
12558                   I0 = 18*(I+1)-17
12559                   READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12560                   WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12561     7          CONTINUE
12562             ENDIF
12563             I0 = 18*(NLINES+1)+1
12564             IF (I0.LE.NABIN) THEN
12565                READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12566                WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12567             ENDIF
12568          ENDIF
12569          WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
12570          READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
12571          IF (NBBIN.LT.18) THEN
12572             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
12573          ELSE
12574             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12575          ENDIF
12576          IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
12577          IF (NBBIN.GT.18) THEN
12578             NLINES = DBLE(NBBIN-18)/18.0D0
12579             IF (NLINES.GT.0) THEN
12580                DO 8 I=1,NLINES
12581                   I0 = 18*(I+1)-17
12582                   READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12583                   WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12584     8          CONTINUE
12585             ENDIF
12586             I0 = 18*(NLINES+1)+1
12587             IF (I0.LE.NBBIN) THEN
12588                READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12589                WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12590             ENDIF
12591          ENDIF
12592 *  number of data sets to follow in the Glauber data file
12593 *   this variable is used for checks of consistency of projectile
12594 *   and target mass configurations given in header of Glauber data
12595 *   file and the data-sets which follow in this file
12596          NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12597 *
12598 *  read profile function data
12599          NSET  = 0
12600          NAIDX = 0
12601          IPOLD = 0
12602    10    CONTINUE
12603          NSET = NSET+1
12604          IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12605          READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12606  1002    FORMAT(5I10,E15.5)
12607          IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12608             NAIDX = NAIDX+1
12609             IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12610             IAIDX(NAIDX) = IP
12611             IPOLD = IP
12612          ENDIF
12613          READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12614          READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12615          NLINES = INT(DBLE(ISITEB)/7.0D0)
12616          IF (NLINES.GT.0) THEN
12617             DO 11 I=1,NLINES
12618                READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12619    11       CONTINUE
12620          ENDIF
12621          I0 = 7*NLINES+1
12622          IF (I0.LE.ISITEB)
12623      &      READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12624          GOTO 10
12625   100    CONTINUE
12626          NSET = NSET-1
12627          IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12628          WRITE(LOUT,'(/,1X,A)')
12629      &   ' projectiles other than protons and nuclei: (particle index)'
12630          IF (NAIDX.GT.0) THEN
12631             WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12632          ELSE
12633             WRITE(LOUT,'(6X,A)') 'none'
12634          ENDIF
12635 *
12636          CLOSE(LDAT)
12637          WRITE(LOUT,*)
12638          LREAD = .TRUE.
12639
12640          IF (NCOMPO.EQ.0) THEN
12641             DO 12 J=1,NBBIN
12642                NCOMPO = NCOMPO+1
12643                IEMUMA(NCOMPO) = IBBIN(J)
12644                IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12645                EMUFRA(NCOMPO) = 1.0D0
12646    12       CONTINUE
12647             IEMUL = 1
12648          ENDIF
12649 *
12650 * calculate profile function for certain set of parameters
12651 *
12652       ELSE
12653
12654 c        write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12655 *
12656 * check for type of projectile and set index-offset to entry in
12657 * Glauber data array correspondingly
12658          IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12659          IF (IOFFST(IDPROJ).EQ.-1) THEN
12660             STOP ' GLBSET: no data for this projectile !'
12661          ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12662             IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12663          ELSE
12664             IDXOFF = 0
12665          ENDIF
12666 *
12667 * get energy bin and interpolation factor
12668          IF (LCMS) THEN
12669             E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12670          ELSE
12671             E = ELAB
12672          ENDIF
12673          E = LOG10(E)
12674          IF (E.LT.ELO) THEN
12675             IF (LFRST1) THEN
12676                WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12677                LFRST1 = .FALSE.
12678             ENDIF
12679             E = ELO
12680          ENDIF
12681          IF (E.GT.EHI) THEN
12682             IF (LFRST2) THEN
12683                WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12684                LFRST2 = .FALSE.
12685             ENDIF
12686             E = EHI
12687          ENDIF
12688          IE0  = (E-ELO)/DEBIN+1
12689          IE1  = IE0+1
12690          FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12691 *
12692 * get target nucleus index
12693          KB = 0
12694          NBACC = KBACC
12695          DO 20 I=1,NBBIN
12696             NBDIFF = ABS(NB-IBBIN(I))
12697             IF (NB.EQ.IBBIN(I)) THEN
12698                KB = I
12699                GOTO 21
12700             ELSEIF (NBDIFF.LE.NBACC) THEN
12701                KB = I
12702                NBACC = NBDIFF
12703             ENDIF
12704    20    CONTINUE
12705          IF (KB.NE.0) GOTO 21
12706          WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12707          STOP
12708    21    CONTINUE
12709 *
12710 * get projectile nucleus bin and interpolation factor
12711          KA0 = 0
12712          KA1 = 0
12713          FACNA = 0
12714          IF (IDXOFF.GT.0) THEN
12715             KA0 = 1
12716             KA1 = 1
12717             KABIN = 1
12718          ELSE
12719             IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12720             DO 22 I=1,NABIN
12721                IF (NA.EQ.IABIN(I)) THEN
12722                   KA0 = I
12723                   KA1 = I
12724                   GOTO 23
12725                ELSEIF (NA.LT.IABIN(I)) THEN
12726                   KA0 = I-1
12727                   KA1 = I
12728                   GOTO 23
12729                ENDIF
12730    22       CONTINUE
12731             WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12732             STOP
12733    23       CONTINUE
12734             IF (KA0.NE.KA1)
12735      &         FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12736             KABIN = NABIN
12737          ENDIF
12738 *
12739 * interpolate profile functions for interactions ka0-kb and ka1-kb
12740 * for energy E separately
12741          IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12742          IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12743          IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12744          IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12745          DO 30 I=1,ISITEB
12746             BPRO0(I) = BPROFL(IDX0,I)
12747      &                 +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12748             BPRO1(I) = BPROFL(IDY0,I)
12749      &                 +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12750    30    CONTINUE
12751          RADB  = DT_RNCLUS(NB)
12752          BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12753          BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12754 *
12755 * interpolate cross sections for energy E and projectile mass
12756          DO 31 I=1,6
12757             XS0   = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12758             XS1   = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12759             XS(I) = XS0+FACNA*(XS1-XS0)
12760             XE0   = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12761             XE1   = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12762             XE(I) = XE0+FACNA*(XE1-XE0)
12763    31    CONTINUE
12764 *
12765 * interpolate between ka0 and ka1
12766          RADA = DT_RNCLUS(NA)
12767          BMX  = 2.0D0*(RADA+RADB)
12768          BSTP = BMX/DBLE(ISITEB-1)
12769          BPRO(1) = ZERO
12770          DO 32 I=1,ISITEB-1
12771             B = DBLE(I)*BSTP
12772 *
12773 *   calculate values of profile functions at B
12774             IDX0 = B/BSTP0+1
12775             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12776             IDX1 = MIN(IDX0+1,ISITEB)
12777             FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12778             BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12779             IDX0 = B/BSTP1+1
12780             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12781             IDX1 = MIN(IDX0+1,ISITEB)
12782             FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12783             BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12784 *
12785             BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12786    32    CONTINUE
12787 *
12788 * fill common dtglam
12789          NSITEB   = ISITEB
12790          RASH(1)  = RADA
12791          RBSH(1)  = RADB
12792          BMAX(1)  = BMX
12793          BSTEP(1) = BSTP
12794          DO 33 I=1,KSITEB
12795             BSITE(0,1,1,I) = BPRO(I)
12796    33    CONTINUE
12797 *
12798 * fill common dtglxs
12799          XSTOT(1,1,1) = XS(1)
12800          XSELA(1,1,1) = XS(2)
12801          XSQEP(1,1,1) = XS(3)
12802          XSQET(1,1,1) = XS(4)
12803          XSQE2(1,1,1) = XS(5)
12804          XSPRO(1,1,1) = XS(6)
12805          XETOT(1,1,1) = XE(1)
12806          XEELA(1,1,1) = XE(2)
12807          XEQEP(1,1,1) = XE(3)
12808          XEQET(1,1,1) = XE(4)
12809          XEQE2(1,1,1) = XE(5)
12810          XEPRO(1,1,1) = XE(6)
12811
12812       ENDIF
12813
12814       RETURN
12815       END
12816 *$ CREATE DT_XKSAMP.FOR
12817 *COPY DT_XKSAMP
12818 *
12819 *===xksamp=============================================================*
12820 *
12821       SUBROUTINE DT_XKSAMP(NN,ECM)
12822
12823 ************************************************************************
12824 * Sampling of parton x-values and chain system for one interaction.    *
12825 *                                   processed by S. Roesler, 9.8.95    *
12826 ************************************************************************
12827
12828       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12829       SAVE
12830
12831       PARAMETER ( LINP = 10 ,
12832      &            LOUT = 6 ,
12833      &            LDAT = 9 )
12834
12835       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12836       SAVE
12837
12838       PARAMETER (
12839 * lower cuts for (valence-sea/sea-valence) chain masses
12840 *   antiquark-quark (u/d-sea quark)    (s-sea quark)
12841      &               AMIU = 0.5D0,      AMIS = 0.8D0,
12842 *   quark-diquark   (u/d-sea quark)    (s-sea quark)
12843      &               AMAU = 2.6D0,      AMAS = 2.6D0,
12844 * maximum lower valence-x threshold
12845      &           XVMAX  = 0.98D0,
12846 * fraction of sea-diquarks sampled out of sea-partons
12847 **test
12848 C    &           FRCDIQ = 0.9D0,
12849 **
12850 *
12851      &           SQMA   = 0.7D0,
12852 *
12853 * maximum number of trials to generate x's for the required number
12854 * of sea quark pairs for a given hadron
12855      &           NSEATY = 12
12856 C    &           NSEATY = 3
12857      &          )
12858
12859       LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12860
12861       PARAMETER ( MAXNCL = 260,
12862
12863      &            MAXVQU = MAXNCL,
12864      &            MAXSQU = 20*MAXVQU,
12865      &            MAXINT = MAXVQU+MAXSQU)
12866
12867 * event history
12868
12869       PARAMETER (NMXHKK=200000)
12870
12871       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12872      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12873      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12874
12875 * particle properties (BAMJET index convention)
12876       CHARACTER*8  ANAME
12877       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12878      &                IICH(210),IIBAR(210),K1(210),K2(210)
12879
12880 * interface between Glauber formalism and DPM
12881       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12882      &                INTER1(MAXINT),INTER2(MAXINT)
12883
12884 * properties of interacting particles
12885       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12886
12887 * threshold values for x-sampling (DTUNUC 1.x)
12888       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12889      &                SSMIMQ,VVMTHR
12890
12891 * x-values of partons (DTUNUC 1.x)
12892       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12893      &                XTVQ(MAXVQU),XTVD(MAXVQU),
12894      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
12895      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
12896
12897 * flavors of partons (DTUNUC 1.x)
12898       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12899      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12900      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
12901      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12902      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
12903      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12904      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
12905
12906 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12907       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12908      &                IXPV,IXPS,IXTV,IXTS,
12909      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
12910      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
12911      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
12912      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
12913      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
12914      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
12915      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
12916      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
12917
12918 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12919       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12920      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12921
12922 * auxiliary common for chain system storage (DTUNUC 1.x)
12923       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12924
12925 * flags for input different options
12926       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12927       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12928      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12929
12930 * various options for treatment of partons (DTUNUC 1.x)
12931 * (chain recombination, Cronin,..)
12932       LOGICAL LCO2CR,LINTPT
12933       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12934      &                LCO2CR,LINTPT
12935
12936       DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12937      &          INTLO(MAXINT)
12938
12939 * (1) initializations
12940 *-----------------------------------------------------------------------
12941
12942 **test
12943       IF (ECM.LT.4.5D0) THEN
12944 C        FRCDIQ = 0.6D0
12945          FRCDIQ = 0.4D0
12946       ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12947 C        FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12948          FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12949       ELSE
12950 C        FRCDIQ = 0.9D0
12951          FRCDIQ = 0.7D0
12952       ENDIF
12953 **
12954       DO 30 I=1,MAXSQU
12955          ZUOSP(I) = .FALSE.
12956          ZUOST(I) = .FALSE.
12957          IF (I.LE.MAXVQU) THEN
12958             ZUOVP(I) = .FALSE.
12959             ZUOVT(I) = .FALSE.
12960          ENDIF
12961    30 CONTINUE
12962
12963 * lower thresholds for x-selection
12964 *  sea-quarks       (default: CSEA=0.2)
12965       IF (ECM.LT.10.0D0) THEN
12966 **!!test
12967          XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12968 C        XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12969          NSEA  = NSEATY
12970 C        XSTHR = ONE/ECM**2
12971       ELSE
12972 **sr 30.3.98
12973 C        XSTHR = CSEA/ECM
12974          XSTHR = CSEA/ECM**2
12975 C        XSTHR = ONE/ECM**2
12976 **
12977          IF ((IP.GE.150).AND.(IT.GE.150))
12978      &      XSTHR = 2.5D0/(ECM*SQRT(ECM))
12979          NSEA  = NSEATY
12980       ENDIF
12981 *                   (default: SSMIMA=0.14) used for sea-diquarks (?)
12982       XSSTHR = SSMIMA/ECM
12983       BSQMA  = SQMA/ECM
12984 *  valence-quarks   (default: CVQ=1.0)
12985       XVTHR  = CVQ/ECM
12986 *  valence-diquarks (default: CDQ=2.0)
12987       XDTHR  = CDQ/ECM
12988
12989 * maximum-x for sea-quarks
12990       XVCUT  = XVTHR+XDTHR
12991       IF (XVCUT.GT.XVMAX) THEN
12992          XVCUT = XVMAX
12993          XVTHR = XVCUT/3.0D0
12994          XDTHR = XVCUT-XVTHR
12995       ENDIF
12996       XXSEAM = ONE-XVCUT
12997 **sr 18.4. test: DPMJET
12998 C     XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
12999 C    &            - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
13000 C    &             -0.01*(1.D0+1.5D0*DT_RNDM(V3))
13001 **
13002 * maximum number of sea-pairs allowed kinematically
13003 C     NSMAX  = INT(OHALF*XXSEAM/XSTHR)
13004       RNSMAX = OHALF*XXSEAM/XSTHR
13005       IF (RNSMAX.GT.10000.0D0) THEN
13006          NSMAX = 10000
13007       ELSE
13008          NSMAX = INT(OHALF*XXSEAM/XSTHR)
13009       ENDIF
13010 * check kinematical limit for valence-x thresholds
13011 * (should be obsolete now)
13012       IF (XVCUT.GT.XVMAX) THEN
13013          WRITE(LOUT,1000) XVCUT,ECM
13014  1000    FORMAT(' XKSAMP:    kin. limit for valence-x',
13015      &          '  thresholds not allowed (',2E9.3,')')
13016 C        XVTHR = XVMAX-XDTHR
13017 C        IF (XVTHR.LT.ZERO) STOP
13018          STOP
13019       ENDIF
13020
13021 * set eta for valence-x sampling (BETREJ)
13022 *   (UNON per default, UNOM used for projectile mesons only)
13023       IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
13024          UNOPRV = UNOM
13025       ELSE
13026          UNOPRV = UNON
13027       ENDIF
13028
13029 * (2) select parton x-values of interacting projectile nucleons
13030 *-----------------------------------------------------------------------
13031
13032       IXPV = 0
13033       IXPS = 0
13034
13035       DO 100 IPP=1,IP
13036 *   get interacting projectile nucleon as sampled by Glauber
13037          IF (JSSH(IPP).NE.0) THEN
13038             IXSTMP = IXPS
13039             IXVTMP = IXPV
13040    99       CONTINUE
13041             IXPS   = IXSTMP
13042             IXPV   = IXVTMP
13043 *     JIPP is the actual number of sea-pairs sampled for this nucleon
13044             JIPP   = MIN(JSSH(IPP)-1,NSMAX)
13045    41       CONTINUE
13046             XXSEA  = ZERO
13047             IF (JIPP.GT.0) THEN
13048                XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
13049 *???
13050                IF (XSTHR.GE.XSMAX) THEN
13051                   JIPP = JIPP-1
13052                   GOTO 41
13053                ENDIF
13054
13055 *>>>get x-values of sea-quark pairs
13056                NSCOUN = 0
13057                PLW = 0.5D0
13058    40          CONTINUE
13059 *     accumulator for sea x-values
13060                XXSEA  = ZERO
13061                NSCOUN = NSCOUN+1
13062                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13063                IF (NSCOUN.GT.NSEA) THEN
13064 *     decrease the number of interactions after NSEA trials
13065                   JIPP   = JIPP-1
13066                   NSCOUN = 0
13067                ENDIF
13068                DO 70 ISQ=1,JIPP
13069 *     sea-quarks
13070                   IF (IPSQ(IXPS+1).LE.2) THEN
13071 **sr 8.4.98 (1/sqrt(x))
13072 C                    XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13073 C                    XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13074                      XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13075 **
13076                   ELSE
13077                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13078                         XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13079                      ELSE
13080 **sr 8.4.98 (1/sqrt(x))
13081 C                       XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13082 C                       XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13083                         XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13084 **
13085                      ENDIF
13086                   ENDIF
13087 *     sea-antiquarks
13088                   IF (IPSAQ(IXPS+1).GE.-2) THEN
13089 **sr 8.4.98 (1/sqrt(x))
13090 C                    XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13091 C                    XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13092                      XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13093 **
13094                   ELSE
13095                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13096                         XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13097                      ELSE
13098 **sr 8.4.98 (1/sqrt(x))
13099 C                       XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13100 C                       XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13101                         XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13102 **
13103                      ENDIF
13104                   ENDIF
13105                   XXSEA = XXSEA+XPSQI+XPSAQI
13106 *     check for maximum allowed sea x-value
13107                   IF (XXSEA.GE.XXSEAM) THEN
13108                      IXPS = IXPS-ISQ+1
13109                      GOTO 40
13110                   ENDIF
13111 *     accept this sea-quark pair
13112                   IXPS         = IXPS+1
13113                   XPSQ(IXPS)   = XPSQI
13114                   XPSAQ(IXPS)  = XPSAQI
13115                   IFROSP(IXPS) = IPP
13116                   ZUOSP(IXPS)  = .TRUE.
13117    70          CONTINUE
13118             ENDIF
13119
13120 *>>>get x-values of valence partons
13121 *     valence quark
13122             IF (XVTHR.GT.0.05D0) THEN
13123                XVHI  = ONE-XXSEA-XDTHR
13124                XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
13125             ELSE
13126    90          CONTINUE
13127                XPVQI = DT_DBETAR(OHALF,UNOPRV)
13128                IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
13129      &                                                     GOTO 90
13130             ENDIF
13131 *     valence diquark
13132             XPVDI = ONE-XPVQI-XXSEA
13133 *       reject according to x**1.5
13134             XDTMP = XPVDI**1.5D0
13135             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
13136 *     accept these valence partons
13137             IXPV         = IXPV+1
13138             XPVQ(IXPV)   = XPVQI
13139             XPVD(IXPV)   = XPVDI
13140             IFROVP(IXPV) = IPP
13141             ITOVP(IPP)   = IXPV
13142             ZUOVP(IXPV)  = .TRUE.
13143
13144          ENDIF
13145   100 CONTINUE
13146
13147 * (3) select parton x-values of interacting target nucleons
13148 *-----------------------------------------------------------------------
13149
13150       IXTV = 0
13151       IXTS = 0
13152
13153       DO 170 ITT=1,IT
13154 *   get interacting target nucleon as sampled by Glauber
13155          IF (JTSH(ITT).NE.0) THEN
13156             IXSTMP = IXTS
13157             IXVTMP = IXTV
13158   169       CONTINUE
13159             IXTS   = IXSTMP
13160             IXTV   = IXVTMP
13161 *     JITT is the actual number of sea-pairs sampled for this nucleon
13162             JITT   = MIN(JTSH(ITT)-1,NSMAX)
13163   111       CONTINUE
13164             XXSEA  = ZERO
13165             IF (JITT.GT.0) THEN
13166                XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
13167 *???
13168                IF (XSTHR.GE.XSMAX) THEN
13169                   JITT = JITT-1
13170                   GOTO 111
13171                ENDIF
13172
13173 *>>>get x-values of sea-quark pairs
13174                NSCOUN = 0
13175                PLW = 0.5D0
13176   110          CONTINUE
13177 *     accumulator for sea x-values
13178                XXSEA  = ZERO
13179                NSCOUN = NSCOUN+1
13180                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13181                IF (NSCOUN.GT.NSEA)THEN
13182 *     decrease the number of interactions after NSEA trials
13183                   JITT   = JITT-1
13184                   NSCOUN = 0
13185                ENDIF
13186                DO 140 ISQ=1,JITT
13187 *     sea-quarks
13188                   IF (ITSQ(IXTS+1).LE.2) THEN
13189 **sr 8.4.98 (1/sqrt(x))
13190 C                    XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13191 C                    XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13192                      XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13193 **
13194                   ELSE
13195                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13196                         XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13197                      ELSE
13198 **sr 8.4.98 (1/sqrt(x))
13199 C                       XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13200 C                       XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13201                         XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13202 **
13203                      ENDIF
13204                   ENDIF
13205 *     sea-antiquarks
13206                   IF (ITSAQ(IXTS+1).GE.-2) THEN
13207 **sr 8.4.98 (1/sqrt(x))
13208 C                    XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13209 C                    XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13210                      XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13211 **
13212                   ELSE
13213                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13214                         XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13215                      ELSE
13216 **sr 8.4.98 (1/sqrt(x))
13217 C                       XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13218 C                       XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13219                         XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13220 **
13221                      ENDIF
13222                   ENDIF
13223                   XXSEA = XXSEA+XTSQI+XTSAQI
13224 *     check for maximum allowed sea x-value
13225                   IF (XXSEA.GE.XXSEAM) THEN
13226                      IXTS = IXTS-ISQ+1
13227                      GOTO 110
13228                   ENDIF
13229 *     accept this sea-quark pair
13230                   IXTS         = IXTS+1
13231                   XTSQ(IXTS)   = XTSQI
13232                   XTSAQ(IXTS)  = XTSAQI
13233                   IFROST(IXTS) = ITT
13234                   ZUOST(IXTS)  = .TRUE.
13235   140          CONTINUE
13236             ENDIF
13237
13238 *>>>get x-values of valence partons
13239 *     valence quark
13240             IF (XVTHR.GT.0.05D0) THEN
13241                XVHI  = ONE-XXSEA-XDTHR
13242                XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
13243             ELSE
13244   160          CONTINUE
13245                XTVQI = DT_DBETAR(OHALF,UNON)
13246                IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
13247      &                                                    GOTO 160
13248             ENDIF
13249 *     valence diquark
13250             XTVDI = ONE-XTVQI-XXSEA
13251 *       reject according to x**1.5
13252             XDTMP = XTVDI**1.5D0
13253             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
13254 *     accept these valence partons
13255             IXTV         = IXTV+1
13256             XTVQ(IXTV)   = XTVQI
13257             XTVD(IXTV)   = XTVDI
13258             IFROVT(IXTV) = ITT
13259             ITOVT(ITT)   = IXTV
13260             ZUOVT(IXTV)  = .TRUE.
13261
13262          ENDIF
13263   170 CONTINUE
13264
13265 * (4) get valence-valence chains
13266 *-----------------------------------------------------------------------
13267
13268       NVV = 0
13269       DO 240 I=1,NN
13270          INTLO(I) = .TRUE.
13271          IPVAL    = ITOVP(INTER1(I))
13272          ITVAL    = ITOVT(INTER2(I))
13273          IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
13274             INTLO(I)      = .FALSE.
13275             ZUOVP(IPVAL)  = .FALSE.
13276             ZUOVT(ITVAL)  = .FALSE.
13277             NVV           = NVV+1
13278             ISKPCH(8,NVV) = 0
13279             INTVV1(NVV)   = IPVAL
13280             INTVV2(NVV)   = ITVAL
13281          ENDIF
13282   240 CONTINUE
13283
13284 * (5) get sea-valence chains
13285 *-----------------------------------------------------------------------
13286
13287       NSV = 0
13288       NDV = 0
13289       PLW = 0.5D0
13290       DO 270 I=1,NN
13291          IF (INTLO(I)) THEN
13292             IPVAL = ITOVP(INTER1(I))
13293             ITVAL = ITOVT(INTER2(I))
13294             DO 250 J=1,IXPS
13295                IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
13296      &                                ZUOVT(ITVAL)) THEN
13297                   ZUOSP(J)     = .FALSE.
13298                   ZUOVT(ITVAL) = .FALSE.
13299                   INTLO(I)     = .FALSE.
13300                   IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
13301 *   sample sea-diquark pair
13302                      CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
13303                      IF (IREJ1.EQ.0) GOTO 260
13304                   ENDIF
13305                   NSV           = NSV+1
13306                   ISKPCH(4,NSV) = 0
13307                   INTSV1(NSV)   = J
13308                   INTSV2(NSV)   = ITVAL
13309
13310 *>>>correct chain kinematics according to minimum chain masses
13311 *     the actual chain masses
13312                   AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
13313                   AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
13314 *     get lower mass cuts
13315                   IF (IPSQ(J).EQ.3) THEN
13316 *       q being s-quark
13317                      AMCHK1 = AMAS
13318                      AMCHK2 = AMIS
13319                   ELSE
13320 *       q being u/d-quark
13321                      AMCHK1 = AMAU
13322                      AMCHK2 = AMIU
13323                   ENDIF
13324 *       q-qq chain
13325 *         chain mass above minimum - resampling of sea-q x-value
13326                   IF (AMSVQ1.GT.AMCHK1) THEN
13327                      XPSQTH      = AMCHK1/(XTVD(ITVAL)*ECM**2)
13328 **sr 8.4.98 (1/sqrt(x))
13329 C                    XPSQXX      = DT_SAMPEX(XPSQTH,XPSQ(J))
13330 C                    XPSQXX      = DT_SAMSQX(XPSQTH,XPSQ(J))
13331                      XPSQXX      = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
13332 **
13333                      XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
13334                      XPSQ(J)     = XPSQXX
13335 *         chain mass below minimum - reset sea-q x-value and correct
13336 *                                    diquark-x of the same nucleon
13337                   ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13338                      XPSQW       = AMCHK1/(XTVD(ITVAL)*ECM**2)
13339                      DXPSQ       = XPSQW-XPSQ(J)
13340                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13341                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13342                         XPSQ(J)     = XPSQW
13343                      ENDIF
13344                   ENDIF
13345 *       aq-q chain
13346 *         chain mass below minimum - reset sea-aq x-value and correct
13347 *                                    diquark-x of the same nucleon
13348                   IF (AMSVQ2.LT.AMCHK2) THEN
13349                      XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
13350                      DXPSQ = XPSQW-XPSAQ(J)
13351                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13352                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13353                         XPSAQ(J)    = XPSQW
13354                      ENDIF
13355                   ENDIF
13356 *>>>end of chain mass correction
13357
13358                   GOTO 260
13359                ENDIF
13360   250       CONTINUE
13361          ENDIF
13362   260    CONTINUE
13363   270 CONTINUE
13364
13365 * (6) get valence-sea chains
13366 *-----------------------------------------------------------------------
13367
13368       NVS = 0
13369       NVD = 0
13370       DO 300 I=1,NN
13371          IF (INTLO(I)) THEN
13372             IPVAL = ITOVP(INTER1(I))
13373             ITVAL = ITOVT(INTER2(I))
13374             DO 280 J=1,IXTS
13375                IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
13376      &                  (IFROST(J).EQ.INTER2(I))) THEN
13377                   ZUOST(J)     = .FALSE.
13378                   ZUOVP(IPVAL) = .FALSE.
13379                   INTLO(I)     = .FALSE.
13380                   IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13381 *   sample sea-diquark pair
13382                      CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
13383                      IF (IREJ1.EQ.0) GOTO 290
13384                   ENDIF
13385                   NVS           = NVS + 1
13386                   ISKPCH(6,NVS) = 0
13387                   INTVS1(NVS)   = IPVAL
13388                   INTVS2(NVS)   = J
13389
13390 *>>>correct chain kinematics according to minimum chain masses
13391 *     the actual chain masses
13392                   AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
13393                   AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
13394 *     get lower mass cuts
13395                   IF (ITSQ(J).EQ.3) THEN
13396 *       q being s-quark
13397                      AMCHK1 = AMIS
13398                      AMCHK2 = AMAS
13399                   ELSE
13400 *       q being u/d-quark
13401                      AMCHK1 = AMIU
13402                      AMCHK2 = AMAU
13403                   ENDIF
13404 *       q-aq chain
13405 *         chain mass below minimum - reset sea-aq x-value and correct
13406 *                                    diquark-x of the same nucleon
13407                   IF (AMVSQ1.LT.AMCHK1) THEN
13408                      XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
13409                      DXTSQ = XTSQW-XTSAQ(J)
13410                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13411                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13412                         XTSAQ(J)    = XTSQW
13413                      ENDIF
13414                   ENDIF
13415 *       qq-q chain
13416 *         chain mass above minimum - resampling of sea-q x-value
13417                   IF (AMVSQ2.GT.AMCHK2) THEN
13418                      XTSQTH      = AMCHK2/(XPVD(IPVAL)*ECM**2)
13419 **sr 8.4.98 (1/sqrt(x))
13420 C                    XTSQXX      = DT_SAMPEX(XTSQTH,XTSQ(J))
13421 C                    XTSQXX      = DT_SAMSQX(XTSQTH,XTSQ(J))
13422                      XTSQXX      = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13423 **
13424                      XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
13425                      XTSQ(J)     = XTSQXX
13426 *         chain mass below minimum - reset sea-q x-value and correct
13427 *                                    diquark-x of the same nucleon
13428                   ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13429                      XTSQW       = AMCHK2/(XPVD(IPVAL)*ECM**2)
13430                      DXTSQ       = XTSQW-XTSQ(J)
13431                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13432                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13433                         XTSQ(J)     = XTSQW
13434                      ENDIF
13435                   ENDIF
13436 *>>>end of chain mass correction
13437
13438                   GOTO 290
13439                ENDIF
13440   280       CONTINUE
13441          ENDIF
13442   290    CONTINUE
13443   300 CONTINUE
13444
13445 * (7) get sea-sea chains
13446 *-----------------------------------------------------------------------
13447
13448       NSS = 0
13449       NDS = 0
13450       NSD = 0
13451       DO 420 I=1,NN
13452          IF (INTLO(I)) THEN
13453             IPVAL = ITOVP(INTER1(I))
13454             ITVAL = ITOVT(INTER2(I))
13455 *   loop over target partons not yet matched
13456             DO 400 J=1,IXTS
13457                IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
13458 *   loop over projectile partons not yet matched
13459                   DO 390 JJ=1,IXPS
13460                      IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
13461                         ZUOSP(JJ)     = .FALSE.
13462                         ZUOST(J)      = .FALSE.
13463                         INTLO(I)      = .FALSE.
13464                         NSS           = NSS+1
13465                         ISKPCH(1,NSS) = 0
13466                         INTSS1(NSS)   = JJ
13467                         INTSS2(NSS)   = J
13468
13469 *---->chain recombination option
13470                         VALFRA        = DBLE(NVV/(NVV+IXPS+IXTS))
13471                         IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
13472      &                                                             THEN
13473 *       sea-sea chains may recombine with valence-valence chains
13474 *       only if they have the same projectile or target nucleon
13475                            DO 4201 IVV=1,NVV
13476                               IF (ISKPCH(8,IVV).NE.99) THEN
13477                                  IXVPR = INTVV1(IVV)
13478                                  IXVTA = INTVV2(IVV)
13479                                  IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
13480      &                               (INTER2(I).EQ.IFROVT(IXVTA))) THEN
13481 *         recombination possible, drop old v-v and s-s chains
13482                                     ISKPCH(1,NSS) = 99
13483                                     ISKPCH(8,IVV) = 99
13484
13485 *         (a) assign new s-v chains
13486 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
13487                                     IF (LSEADI.AND.
13488      &                                  (DT_RNDM(VALFRA).GT.FRCDIQ))
13489      &                                                             THEN
13490 *           sample sea-diquark pair
13491                                        CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
13492      &                                                      IREJ1)
13493                                        IF (IREJ1.EQ.0) GOTO 4202
13494                                     ENDIF
13495                                     NSV           = NSV+1
13496                                     ISKPCH(4,NSV) = 0
13497                                     INTSV1(NSV)   = JJ
13498                                     INTSV2(NSV)   = IXVTA
13499 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13500 *           the actual chain masses
13501                                     AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
13502      &                                                     *ECM**2
13503                                     AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
13504      &                                                     *ECM**2
13505 *           get lower mass cuts
13506                                     IF (IPSQ(JJ).EQ.3) THEN
13507 *             q being s-quark
13508                                        AMCHK1 = AMAS
13509                                        AMCHK2 = AMIS
13510                                     ELSE
13511 *             q being u/d-quark
13512                                        AMCHK1 = AMAU
13513                                        AMCHK2 = AMIU
13514                                     ENDIF
13515 *           q-qq chain
13516 *             chain mass above minimum - resampling of sea-q x-value
13517                                     IF (AMSVQ1.GT.AMCHK1) THEN
13518                                        XPSQTH      =
13519      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
13520 **sr 8.4.98 (1/sqrt(x))
13521                                        XPSQXX      =
13522      &                                    DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
13523 C    &                                    DT_SAMSQX(XPSQTH,XPSQ(JJ))
13524 C    &                                    DT_SAMPEX(XPSQTH,XPSQ(JJ))
13525 **
13526                                        XPVD(IPVAL) =
13527      &                                    XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
13528                                        XPSQ(JJ)    = XPSQXX
13529 *             chain mass below minimum - reset sea-q x-value and correct
13530 *                                        diquark-x of the same nucleon
13531                                     ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13532                                        XPSQW =
13533      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
13534                                        DXPSQ = XPSQW-XPSQ(JJ)
13535                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13536      &                                                            THEN
13537                                           XPVD(IPVAL) =
13538      &                                       XPVD(IPVAL)-DXPSQ
13539                                           XPSQ(JJ)    = XPSQW
13540                                        ENDIF
13541                                     ENDIF
13542 *           aq-q chain
13543 *             chain mass below minimum - reset sea-aq x-value and correct
13544 *                                        diquark-x of the same nucleon
13545                                     IF (AMSVQ2.LT.AMCHK2) THEN
13546                                        XPSQW =
13547      &                                    AMCHK2/(XTVQ(IXVTA)*ECM**2)
13548                                        DXPSQ = XPSQW-XPSAQ(JJ)
13549                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13550      &                                                            THEN
13551                                           XPVD(IPVAL) =
13552      &                                       XPVD(IPVAL)-DXPSQ
13553                                           XPSAQ(JJ)   = XPSQW
13554                                        ENDIF
13555                                     ENDIF
13556 *>>>>>>>>>>>end of chain mass correction
13557  4202                               CONTINUE
13558
13559 *         (b) assign new v-s chains
13560 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
13561                                     IF (LSEADI.AND.(
13562      &                                  DT_RNDM(AMSVQ2).GT.FRCDIQ))
13563      &                                                             THEN
13564 *           sample sea-diquark pair
13565                                        CALL DT_SAMSDQ(ECM,IXVPR,J,1,
13566      &                                                      IREJ1)
13567                                        IF (IREJ1.EQ.0) GOTO 4203
13568                                     ENDIF
13569                                     NVS           = NVS+1
13570                                     ISKPCH(6,NVS) = 0
13571                                     INTVS1(NVS)   = IXVPR
13572                                     INTVS2(NVS)   = J
13573 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13574 *           the actual chain masses
13575                                     AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
13576                                     AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
13577 *           get lower mass cuts
13578                                     IF (ITSQ(J).EQ.3) THEN
13579 *             q being s-quark
13580                                        AMCHK1 = AMIS
13581                                        AMCHK2 = AMAS
13582                                     ELSE
13583 *             q being u/d-quark
13584                                        AMCHK1 = AMIU
13585                                        AMCHK2 = AMAU
13586                                     ENDIF
13587 *           q-aq chain
13588 *             chain mass below minimum - reset sea-aq x-value and correct
13589 *                                        diquark-x of the same nucleon
13590                                     IF (AMVSQ1.LT.AMCHK1) THEN
13591                                        XTSQW =
13592      &                                    AMCHK1/(XPVQ(IXVPR)*ECM**2)
13593                                        DXTSQ = XTSQW-XTSAQ(J)
13594                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13595      &                                                            THEN
13596                                           XTVD(ITVAL) =
13597      &                                       XTVD(ITVAL)-DXTSQ
13598                                           XTSAQ(J)    = XTSQW
13599                                        ENDIF
13600                                     ENDIF
13601                                     IF (AMVSQ2.GT.AMCHK2) THEN
13602                                        XTSQTH      =
13603      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13604 **sr 8.4.98 (1/sqrt(x))
13605                                        XTSQXX      =
13606      &                                    DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13607 C    &                                    DT_SAMSQX(XTSQTH,XTSQ(J))
13608 C    &                                    DT_SAMPEX(XTSQTH,XTSQ(J))
13609 **
13610                                        XTVD(ITVAL) =
13611      &                                    XTVD(ITVAL)+XTSQ(J)-XTSQXX
13612                                        XTSQ(J)     = XTSQXX
13613                                     ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13614                                        XTSQW =
13615      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13616                                        DXTSQ = XTSQW-XTSQ(J)
13617                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13618      &                                                            THEN
13619                                           XTVD(ITVAL) =
13620      &                                       XTVD(ITVAL)-DXTSQ
13621                                           XTSQ(J)     = XTSQW
13622                                        ENDIF
13623                                     ENDIF
13624 *>>>>>>>>>end of chain mass correction
13625  4203                               CONTINUE
13626 *       jump out of s-s chain loop
13627                                     GOTO 420
13628                                  ENDIF
13629                               ENDIF
13630  4201                      CONTINUE
13631                         ENDIF
13632 *---->end of chain recombination option
13633
13634 *     sample sea-diquark pair (projectile)
13635                         IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13636                            CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13637                            IF (IREJ1.EQ.0) THEN
13638                               ISKPCH(1,NSS) = 99
13639                               GOTO 410
13640                            ENDIF
13641                         ENDIF
13642 *     sample sea-diquark pair (target)
13643                         IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13644                            CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13645                            IF (IREJ1.EQ.0) THEN
13646                               ISKPCH(1,NSS) = 99
13647                               GOTO 410
13648                            ENDIF
13649                         ENDIF
13650 *>>>>>correct chain kinematics according to minimum chain masses
13651 *     the actual chain masses
13652                         SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13653                         SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13654 *     check for lower mass cuts
13655                         IF ((SSMA1Q.LT.SSMIMQ).OR.
13656      &                      (SSMA2Q.LT.SSMIMQ)) THEN
13657                            IPVAL = ITOVP(INTER1(I))
13658                            ITVAL = ITOVT(INTER2(I))
13659                            IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13660      &                         (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13661 *       maximum allowed x values for sea quarks
13662                               XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13663      &                                           1.2D0*XSSTHR
13664                               XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13665      &                                           1.2D0*XSSTHR
13666 *       resampling of x values not possible - skip sea-sea chains
13667                               IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13668      &                            (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13669 *       resampling of x for projectile sea quark pair
13670                               ICOUS = 0
13671   310                         CONTINUE
13672                               ICOUS = ICOUS+1
13673                               IF (XSSTHR.GT.0.05D0) THEN
13674                                  XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13675      &                                                         XSPMAX)
13676                                  XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13677      &                                                         XSPMAX)
13678                               ELSE
13679   320                            CONTINUE
13680                                  XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13681                                  IF ((XPSQI.LT.XSSTHR).OR.
13682      &                               (XPSQI.GT.XSPMAX))  GOTO 320
13683   330                            CONTINUE
13684                                  XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13685                                  IF ((XPSAQI.LT.XSSTHR).OR.
13686      &                               (XPSAQI.GT.XSPMAX)) GOTO 330
13687                               ENDIF
13688 *       final test of remaining x for projectile diquark
13689                               XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13690      &                                            +XPSQ(JJ)+XPSAQ(JJ)
13691                               IF (XPVDCO.LE.XDTHR) THEN
13692 *!!!
13693 C                                IF (ICOUS.LT.5) GOTO 310
13694                                  IF (ICOUS.LT.0.5D0) GOTO 310
13695                                  GOTO 380
13696                               ENDIF
13697 *       resampling of x for target sea quark pair
13698                               ICOUS = 0
13699   350                         CONTINUE
13700                               ICOUS = ICOUS+1
13701                               IF (XSSTHR.GT.0.05D0) THEN
13702                                  XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13703      &                                                         XSTMAX)
13704                                  XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13705      &                                                         XSTMAX)
13706                               ELSE
13707   360                            CONTINUE
13708                                  XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13709                                  IF ((XTSQI.LT.XSSTHR).OR.
13710      &                               (XTSQI.GT.XSTMAX))  GOTO 360
13711   370                            CONTINUE
13712                                  XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13713                                  IF ((XTSAQI.LT.XSSTHR).OR.
13714      &                               (XTSAQI.GT.XSTMAX)) GOTO 370
13715                               ENDIF
13716 *       final test of remaining x for target diquark
13717                               XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13718      &                                            +XTSQ(J)+XTSAQ(J)
13719                               IF (XTVDCO.LT.XDTHR) THEN
13720                                  IF (ICOUS.LT.5) GOTO 350
13721                                  GOTO 380
13722                               ENDIF
13723                               XPVD(IPVAL) = XPVDCO
13724                               XTVD(ITVAL) = XTVDCO
13725                               XPSQ(JJ)    = XPSQI
13726                               XPSAQ(JJ)   = XPSAQI
13727                               XTSQ(J)     = XTSQI
13728                               XTSAQ(J)    = XTSAQI
13729 *>>>>>end of chain mass correction
13730                               GOTO 410
13731                            ENDIF
13732 *     come here to discard s-s interaction
13733 *     resampling of x values not allowed or unsuccessful
13734   380                      CONTINUE
13735                            INTLO(I)  = .FALSE.
13736                            ZUOST(J)  = .TRUE.
13737                            ZUOSP(JJ) = .TRUE.
13738                            NSS       = NSS-1
13739                         ENDIF
13740 *   consider next s-s interaction
13741                         GOTO 410
13742                      ENDIF
13743   390             CONTINUE
13744                ENDIF
13745   400       CONTINUE
13746          ENDIF
13747   410    CONTINUE
13748   420 CONTINUE
13749
13750 * correct x-values of valence quarks for non-matching sea quarks
13751       DO 430 I=1,IXPS
13752          IF (ZUOSP(I)) THEN
13753             IPVAL       = ITOVP(IFROSP(I))
13754             XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13755             XPSQ(I)     = ZERO
13756             XPSAQ(I)    = ZERO
13757             ZUOSP(I)    = .FALSE.
13758          ENDIF
13759   430 CONTINUE
13760       DO 440 I=1,IXTS
13761          IF (ZUOST(I)) THEN
13762             ITVAL       = ITOVT(IFROST(I))
13763             XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13764             XTSQ(I)     = ZERO
13765             XTSAQ(I)    = ZERO
13766             ZUOST(I)    = .FALSE.
13767          ENDIF
13768   440 CONTINUE
13769       DO 450 I=1,IXPV
13770          IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13771   450 CONTINUE
13772       DO 460 I=1,IXTV
13773          IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13774   460 CONTINUE
13775
13776       RETURN
13777       END
13778
13779 *$ CREATE DT_SAMSDQ.FOR
13780 *COPY DT_SAMSDQ
13781 *
13782 *===samsdq=============================================================*
13783 *
13784       SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13785
13786 ************************************************************************
13787 * SAMpling of Sea-DiQuarks                                             *
13788 *              ECM        cm-energy of the nucleon-nucleon system      *
13789 *              IDX1,2     indices of x-values of the participating     *
13790 *                         partons (IDX2 is always the sea-q-pair to be *
13791 *                         changed to sea-qq-pair)                      *
13792 *              MODE       = 1  valence-q - sea-diq                     *
13793 *                         = 2  sea-diq   - valence-q                   *
13794 *                         = 3  sea-q     - sea-diq                     *
13795 *                         = 4  sea-diq   - sea-q                       *
13796 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS.                               *
13797 * This version dated 17.10.95 is written by S. Roesler                 *
13798 ************************************************************************
13799
13800       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13801       SAVE
13802
13803       PARAMETER (ZERO=0.0D0)
13804
13805 * threshold values for x-sampling (DTUNUC 1.x)
13806       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13807      &                SSMIMQ,VVMTHR
13808
13809 * various options for treatment of partons (DTUNUC 1.x)
13810 * (chain recombination, Cronin,..)
13811       LOGICAL LCO2CR,LINTPT
13812       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13813      &                LCO2CR,LINTPT
13814
13815       PARAMETER ( MAXNCL = 260,
13816
13817      &            MAXVQU = MAXNCL,
13818      &            MAXSQU = 20*MAXVQU,
13819      &            MAXINT = MAXVQU+MAXSQU)
13820
13821 * x-values of partons (DTUNUC 1.x)
13822       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13823      &                XTVQ(MAXVQU),XTVD(MAXVQU),
13824      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
13825      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
13826
13827 * flavors of partons (DTUNUC 1.x)
13828       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13829      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13830      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
13831      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13832      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
13833      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13834      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
13835
13836 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13837       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13838      &                IXPV,IXPS,IXTV,IXTS,
13839      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
13840      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
13841      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
13842      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
13843      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
13844      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
13845      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
13846      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
13847
13848 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13849       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13850      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13851
13852 * auxiliary common for chain system storage (DTUNUC 1.x)
13853       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13854
13855       IREJ = 0
13856 *  threshold-x for valence diquarks
13857       XDTHR = CDQ/ECM
13858
13859       GOTO (1,2,3,4) MODE
13860
13861 *---------------------------------------------------------------------
13862 * proj. valence partons - targ. sea partons
13863 * get x-values and flavors for target sea-diquark pair
13864
13865     1 CONTINUE
13866       IDXVP = IDX1
13867       IDXST = IDX2
13868
13869 *  index of corr. val-diquark-x in target nucleon
13870       IDXVT = ITOVT(IFROST(IDXST))
13871 *  available x above diquark thresholds for valence- and sea-diquarks
13872       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13873
13874       IF (XXD.GE.ZERO) THEN
13875 *  x-values for the three diquarks of the target nucleon
13876          RR1    = DT_RNDM(XXD)
13877          RR2    = DT_RNDM(RR1)
13878          RR3    = DT_RNDM(RR2)
13879          SR123  = RR1+RR2+RR3
13880          XXTV   = XDTHR+RR1*XXD/SR123
13881          XXTSQ  = XDTHR+RR2*XXD/SR123
13882          XXTSAQ = XDTHR+RR3*XXD/SR123
13883       ELSE
13884          XXTV   = XTVD(IDXVT)
13885          XXTSQ  = XTSQ(IDXST)
13886          XXTSAQ = XTSAQ(IDXST)
13887       ENDIF
13888 *  flavor of the second quarks in the sea-diquark pair
13889       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13890       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13891 *  check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13892       AM1    = XXTSQ *XPVQ(IDXVP)*ECM**2
13893       AM2    = XXTSAQ*XPVD(IDXVP)*ECM**2
13894       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13895 *    ss-asas pair
13896      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13897          IREJ = 1
13898          RETURN
13899       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13900 *    at least one strange quark
13901      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13902          IREJ = 1
13903          RETURN
13904       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13905          IREJ = 1
13906          RETURN
13907       ENDIF
13908 *  accept the new sea-diquark
13909       XTVD(IDXVT)   = XXTV
13910       XTSQ(IDXST)   = XXTSQ
13911       XTSAQ(IDXST)  = XXTSAQ
13912       NVD           = NVD+1
13913       INTVD1(NVD)   = IDXVP
13914       INTVD2(NVD)   = IDXST
13915       ISKPCH(7,NVD) = 0
13916       RETURN
13917
13918 *---------------------------------------------------------------------
13919 * proj. sea partons - targ. valence partons
13920 * get x-values and flavors for projectile sea-diquark pair
13921
13922     2 CONTINUE
13923       IDXSP = IDX2
13924       IDXVT = IDX1
13925
13926 *  index of corr. val-diquark-x in projectile nucleon
13927       IDXVP = ITOVP(IFROSP(IDXSP))
13928 *  available x above diquark thresholds for valence- and sea-diquarks
13929       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13930
13931       IF (XXD.GE.ZERO) THEN
13932 *  x-values for the three diquarks of the projectile nucleon
13933          RR1    = DT_RNDM(XXD)
13934          RR2    = DT_RNDM(RR1)
13935          RR3    = DT_RNDM(RR2)
13936          SR123  = RR1+RR2+RR3
13937          XXPV   = XDTHR+RR1*XXD/SR123
13938          XXPSQ  = XDTHR+RR2*XXD/SR123
13939          XXPSAQ = XDTHR+RR3*XXD/SR123
13940       ELSE
13941          XXPV   = XPVD(IDXVP)
13942          XXPSQ  = XPSQ(IDXSP)
13943          XXPSAQ = XPSAQ(IDXSP)
13944       ENDIF
13945 *  flavor of the second quarks in the sea-diquark pair
13946       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13947       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13948 *  check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13949       AM1    = XXPSQ *XTVQ(IDXVT)*ECM**2
13950       AM2    = XXPSAQ*XTVD(IDXVT)*ECM**2
13951       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13952 *    ss-asas pair
13953      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13954          IREJ = 1
13955          RETURN
13956       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13957 *    at least one strange quark
13958      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13959          IREJ = 1
13960          RETURN
13961       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13962          IREJ = 1
13963          RETURN
13964       ENDIF
13965 *  accept the new sea-diquark
13966       XPVD(IDXVP)   = XXPV
13967       XPSQ(IDXSP)   = XXPSQ
13968       XPSAQ(IDXSP)  = XXPSAQ
13969       NDV           = NDV+1
13970       INTDV1(NDV)   = IDXSP
13971       INTDV2(NDV)   = IDXVT
13972       ISKPCH(5,NDV) = 0
13973       RETURN
13974
13975 *---------------------------------------------------------------------
13976 * proj. sea partons - targ. sea partons
13977 * get x-values and flavors for target sea-diquark pair
13978
13979     3 CONTINUE
13980       IDXSP = IDX1
13981       IDXST = IDX2
13982
13983 *  index of corr. val-diquark-x in target nucleon
13984       IDXVT = ITOVT(IFROST(IDXST))
13985 *  available x above diquark thresholds for valence- and sea-diquarks
13986       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13987
13988       IF (XXD.GE.ZERO) THEN
13989 *  x-values for the three diquarks of the target nucleon
13990          RR1    = DT_RNDM(XXD)
13991          RR2    = DT_RNDM(RR1)
13992          RR3    = DT_RNDM(RR2)
13993          SR123  = RR1+RR2+RR3
13994          XXTV   = XDTHR+RR1*XXD/SR123
13995          XXTSQ  = XDTHR+RR2*XXD/SR123
13996          XXTSAQ = XDTHR+RR3*XXD/SR123
13997       ELSE
13998          XXTV   = XTVD(IDXVT)
13999          XXTSQ  = XTSQ(IDXST)
14000          XXTSAQ = XTSAQ(IDXST)
14001       ENDIF
14002 *  flavor of the second quarks in the sea-diquark pair
14003       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
14004       ITSAQ2(IDXST) = -ITSQ2(IDXST)
14005 *  check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
14006       AM1    = XXTSQ *XPSQ(IDXSP)*ECM**2
14007       AM2    = XXTSAQ*XPSAQ(IDXSP)*ECM**2
14008       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
14009 *    ss-asas pair
14010      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
14011          IREJ = 1
14012          RETURN
14013       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
14014 *    at least one strange quark
14015      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
14016          IREJ = 1
14017          RETURN
14018       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14019          IREJ = 1
14020          RETURN
14021       ENDIF
14022 *  accept the new sea-diquark
14023       XTVD(IDXVT)   = XXTV
14024       XTSQ(IDXST)   = XXTSQ
14025       XTSAQ(IDXST)  = XXTSAQ
14026       NSD           = NSD+1
14027       INTSD1(NSD)   = IDXSP
14028       INTSD2(NSD)   = IDXST
14029       ISKPCH(3,NSD) = 0
14030       RETURN
14031
14032 *---------------------------------------------------------------------
14033 * proj. sea partons - targ. sea partons
14034 * get x-values and flavors for projectile sea-diquark pair
14035
14036     4 CONTINUE
14037       IDXSP = IDX2
14038       IDXST = IDX1
14039
14040 *  index of corr. val-diquark-x in projectile nucleon
14041       IDXVP = ITOVP(IFROSP(IDXSP))
14042 *  available x above diquark thresholds for valence- and sea-diquarks
14043       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
14044
14045       IF (XXD.GE.ZERO) THEN
14046 *  x-values for the three diquarks of the projectile nucleon
14047          RR1    = DT_RNDM(XXD)
14048          RR2    = DT_RNDM(RR1)
14049          RR3    = DT_RNDM(RR2)
14050          SR123  = RR1+RR2+RR3
14051          XXPV   = XDTHR+RR1*XXD/SR123
14052          XXPSQ  = XDTHR+RR2*XXD/SR123
14053          XXPSAQ = XDTHR+RR3*XXD/SR123
14054       ELSE
14055          XXPV   = XPVD(IDXVP)
14056          XXPSQ  = XPSQ(IDXSP)
14057          XXPSAQ = XPSAQ(IDXSP)
14058       ENDIF
14059 *  flavor of the second quarks in the sea-diquark pair
14060       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
14061       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
14062 *  check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
14063       AM1    = XXPSQ *XTSQ(IDXST)*ECM**2
14064       AM2    = XXPSAQ*XTSAQ(IDXST)*ECM**2
14065       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
14066 *    ss-asas pair
14067      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
14068          IREJ = 1
14069          RETURN
14070       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
14071 *    at least one strange quark
14072      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
14073          IREJ = 1
14074          RETURN
14075       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14076          IREJ = 1
14077          RETURN
14078       ENDIF
14079 *  accept the new sea-diquark
14080       XPVD(IDXVP)   = XXPV
14081       XPSQ(IDXSP)   = XXPSQ
14082       XPSAQ(IDXSP)  = XXPSAQ
14083       NDS           = NDS+1
14084       INTDS1(NDS)   = IDXSP
14085       INTDS2(NDS)   = IDXST
14086       ISKPCH(2,NDS) = 0
14087       RETURN
14088       END
14089 *$ CREATE DT_DIFEVT.FOR
14090 *COPY DT_DIFEVT
14091 *
14092 *===difevt=============================================================*
14093 *
14094       SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
14095      &                  IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
14096
14097 ************************************************************************
14098 * Interface to treatment of diffractive interactions.                  *
14099 *  (input)          IFP1/2        PDG-indizes of projectile partons    *
14100 *                                 (baryon: IFP2 - adiquark)            *
14101 *                   PP(4)         projectile 4-momentum                *
14102 *                   IFT1/2        PDG-indizes of target partons        *
14103 *                                 (baryon: IFT1 - adiquark)            *
14104 *                   PT(4)         target 4-momentum                    *
14105 *  (output)         JDIFF = 0     no diffraction                       *
14106 *                         = 1/-1  LMSD/LMDD                            *
14107 *                         = 2/-2  HMSD/HMDD                            *
14108 *                   NCSY          counter for two-chain systems        *
14109 *                                 dumped to DTEVT1                     *
14110 * This version dated 14.02.95 is written by S. Roesler                 *
14111 ************************************************************************
14112
14113       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14114       SAVE
14115
14116       PARAMETER ( LINP = 10 ,
14117      &            LOUT = 6 ,
14118      &            LDAT = 9 )
14119
14120       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
14121      &           OHALF=0.5D0)
14122
14123 * event history
14124
14125       PARAMETER (NMXHKK=200000)
14126
14127       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14128      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14129      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14130
14131 * extended event history
14132       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14133      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14134      &                IHIST(2,NMXHKK)
14135
14136 * flags for diffractive interactions (DTUNUC 1.x)
14137       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14138
14139       DIMENSION PP(4),PT(4)
14140
14141       LOGICAL LFIRST
14142       DATA LFIRST /.TRUE./
14143
14144       IREJ   = 0
14145       JDIFF  = 0
14146       IFLAGD = JDIFF
14147
14148 * cm. energy
14149       XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
14150      &          (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
14151 * identities of projectile hadron / target nucleon
14152       KPROJ = IDT_ICIHAD(IDHKK(MOP))
14153       KTARG = IDT_ICIHAD(IDHKK(MOT))
14154
14155 * single diffractive xsections
14156       CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
14157 * double diffractive xsections
14158 **!! no double diff yet
14159 C     CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
14160       DDTOT = 0.0D0
14161       DDHM  = 0.0D0
14162 **!!
14163 * total inelastic xsection
14164 C     SIGIN  = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
14165       DUMZER = ZERO
14166       CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
14167       SIGIN  = MAX(SIGTO-SIGEL,ZERO)
14168
14169 * fraction of diffractive processes
14170       FRADIF = (SDTOT+DDTOT)/SIGIN
14171
14172       IF (LFIRST) THEN
14173          WRITE(LOUT,1000) XM,SDTOT,SIGIN
14174  1000    FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
14175      &          F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
14176      &          F5.1,' mb',/)
14177          LFIRST = .FALSE.
14178       ENDIF
14179
14180       IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
14181      &    (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
14182 * diffractive interaction requested by x-section or by user
14183          FRASD  = SDTOT/(SDTOT+DDTOT)
14184          FRASDH = SDHM/SDTOT
14185 **sr needs to be specified!!
14186 C        FRADDH = DDHM/DDTOT
14187          FRADDH = 1.0D0
14188 **
14189          IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
14190 *   single diffraction
14191             KDIFF = 1
14192             IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
14193                KP = 2
14194                KT = 0
14195                IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
14196      &               ISINGD.NE.3) THEN
14197                   KP = 0
14198                   KT = 2
14199                ENDIF
14200             ELSE
14201                KP = 1
14202                KT = 0
14203                IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
14204      &               ISINGD.NE.3) THEN
14205                   KP = 0
14206                   KT = 1
14207                ENDIF
14208             ENDIF
14209          ELSE
14210 *   double diffraction
14211             KDIFF = -1
14212             IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
14213                KP = 2
14214                KT = 2
14215             ELSE
14216                KP = 1
14217                KT = 1
14218             ENDIF
14219          ENDIF
14220          CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14221      &               IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14222          IF (IREJ1.EQ.0) THEN
14223             IFLAGD = 2*KDIFF
14224             IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
14225          ELSE
14226             GOTO 9999
14227          ENDIF
14228       ENDIF
14229       JDIFF = IFLAGD
14230
14231       RETURN
14232
14233  9999 CONTINUE
14234       IREJ  = 1
14235       RETURN
14236       END
14237
14238 *$ CREATE DT_DIFFKI.FOR
14239 *COPY DT_DIFFKI
14240 *
14241 *===difkin=============================================================*
14242 *
14243       SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14244      &                  IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
14245
14246 ************************************************************************
14247 * Kinematics of diffractive nucleon-nucleon interaction.               *
14248 *          IFP1/2   PDG-indizes of projectile partons                  *
14249 *                   (baryon: IFP2 - adiquark)                          *
14250 *          PP(4)    projectile 4-momentum                              *
14251 *          IFT1/2   PDG-indizes of target partons                      *
14252 *                   (baryon: IFT1 - adiquark)                          *
14253 *          PT(4)    target 4-momentum                                  *
14254 *          KP   = 0 projectile quasi-elastically scattered             *
14255 *               = 1            excited to low-mass diff. state         *
14256 *               = 2            excited to high-mass diff. state        *
14257 *          KT   = 0 target     quasi-elastically scattered             *
14258 *               = 1            excited to low-mass diff. state         *
14259 *               = 2            excited to high-mass diff. state        *
14260 * This version dated 12.02.95 is written by S. Roesler                 *
14261 ************************************************************************
14262
14263       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14264       SAVE
14265
14266       PARAMETER ( LINP = 10 ,
14267      &            LOUT = 6 ,
14268      &            LDAT = 9 )
14269
14270       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
14271
14272       LOGICAL LSTART
14273
14274 * particle properties (BAMJET index convention)
14275       CHARACTER*8  ANAME
14276       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14277      &                IICH(210),IIBAR(210),K1(210),K2(210)
14278
14279 * flags for input different options
14280       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14281       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14282      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14283
14284 * rejection counter
14285       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14286      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14287      &                IREXCI(3),IRDIFF(2),IRINC
14288
14289 * kinematics of diffractive interactions (DTUNUC 1.x)
14290       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14291      &                PPF(4),PTF(4),
14292      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14293      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14294
14295       DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
14296      &          PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
14297
14298       DATA LSTART /.TRUE./
14299
14300       IF (LSTART) THEN
14301          WRITE(LOUT,2000)
14302  2000    FORMAT(/,1X,'DIFEVT:  diffractive interactions treated ')
14303          LSTART = .FALSE.
14304       ENDIF
14305
14306       IREJ = 0
14307
14308 * initialize common /DTDIKI/
14309       CALL DT_DIFINI
14310 * store momenta of initial incoming particles for emc-check
14311       IF (LEMCCK) THEN
14312          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
14313          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
14314       ENDIF
14315
14316 * masses of initial particles
14317       XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
14318       XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
14319       IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
14320       XMP  = SQRT(XMP2)
14321       XMT  = SQRT(XMT2)
14322 * check quark-input (used to adjust coherence cond. for M-selection)
14323       IBP  = 0
14324       IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
14325       IBT  = 0
14326       IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
14327
14328 * parameter for Lorentz-transformation into nucleon-nucleon cms
14329       DO 3 K=1,4
14330          PITOT(K) = PP(K)+PT(K)
14331     3 CONTINUE
14332       XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
14333       IF (XMTOT2.LE.ZERO) THEN
14334          WRITE(LOUT,1000) XMTOT2
14335  1000    FORMAT(1X,'DIFEVT:   negative cm. energy!  ',
14336      &          'XMTOT2 = ',E12.3)
14337          GOTO 9999
14338       ENDIF
14339       XMTOT = SQRT(XMTOT2)
14340       DO 4 K=1,4
14341          BGTOT(K) = PITOT(K)/XMTOT
14342     4 CONTINUE
14343 * transformation of nucleons into cms
14344       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
14345      &            PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
14346       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
14347      &            PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
14348 * rotation angles
14349       COD = PP1(3)/PPTOT
14350 C     SID = SQRT((ONE-COD)*(ONE+COD))
14351       PPT = SQRT(PP1(1)**2+PP1(2)**2)
14352       SID = PPT/PPTOT
14353       COF = ONE
14354       SIF = ZERO
14355       IF(PPTOT*SID.GT.TINY10) THEN
14356          COF   = PP1(1)/(SID*PPTOT)
14357          SIF   = PP1(2)/(SID*PPTOT)
14358          ANORF = SQRT(COF*COF+SIF*SIF)
14359          COF   = COF/ANORF
14360          SIF   = SIF/ANORF
14361       ENDIF
14362 * check consistency
14363       DO 5 K=1,4
14364          DEV1(K) = ABS(PP1(K)+PT1(K))
14365     5 CONTINUE
14366       DEV1(4) = ABS(DEV1(4)-XMTOT)
14367       IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
14368      &    (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10))     THEN
14369          WRITE(LOUT,1001) DEV1
14370  1001    FORMAT(1X,'DIFEVT:   inconsitent Lorentz-transformation! ',
14371      &          /,8X,4E12.3)
14372          GOTO 9999
14373       ENDIF
14374
14375 * select x-fractions in high-mass diff. interactions
14376       IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
14377
14378 * select diffractive masses
14379 * - projectile
14380       IF (KP.EQ.1) THEN
14381          XMPF = DT_XMLMD(XMTOT)
14382          CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
14383          IF (IREJ1.GT.0) GOTO 9999
14384       ELSEIF (KP.EQ.2) THEN
14385          XMPF = DT_XMHMD(XMTOT,IBP,1)
14386       ELSE
14387          XMPF = XMP
14388       ENDIF
14389 * - target
14390       IF (KT.EQ.1) THEN
14391          XMTF = DT_XMLMD(XMTOT)
14392          CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
14393          IF (IREJ1.GT.0) GOTO 9999
14394       ELSEIF (KT.EQ.2) THEN
14395          XMTF = DT_XMHMD(XMTOT,IBT,2)
14396       ELSE
14397          XMTF = XMT
14398       ENDIF
14399
14400 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
14401       XMPF2 = XMPF**2
14402       XMTF2 = XMTF**2
14403       PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
14404       PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
14405
14406 * select momentum transfer (all t-values used here are <0)
14407 *   minimum absolute value to produce diffractive masses
14408       TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
14409       TT   = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
14410       IF (IREJ1.GT.0) GOTO 9999
14411
14412 * longitudinal momentum of excited/elastically scattered projectile
14413       PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
14414 * total transverse momentum due to t-selection
14415       PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
14416       IF (PPBLT2.LT.ZERO) THEN
14417          WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
14418  1002    FORMAT(1X,'DIFEVT:   inconsistent transverse momentum! ',
14419      &          E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
14420          GOTO 9999
14421       ENDIF
14422       CALL DT_DSFECF(SINPHI,COSPHI)
14423       PPBLT     = SQRT(PPBLT2)
14424       PPBLOB(1) = COSPHI*PPBLT
14425       PPBLOB(2) = SINPHI*PPBLT
14426
14427 * rotate excited/elastically scattered projectile into n-n cms.
14428       CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
14429      &                                                    XX,YY,ZZ)
14430       PPBLOB(1) = XX
14431       PPBLOB(2) = YY
14432       PPBLOB(3) = ZZ
14433
14434 * 4-momentum of excited/elastically scattered target and of exchanged
14435 * Pomeron
14436       DO 6 K=1,4
14437          IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
14438          PPOM1(K) = PP1(K)-PPBLOB(K)
14439     6 CONTINUE
14440       PTBLOB(4) = XMTOT-PPBLOB(4)
14441
14442 * Lorentz-transformation back into system of initial diff. collision
14443       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14444      &            PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
14445      &            PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
14446       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14447      &            PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
14448      &            PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
14449       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14450      &            PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
14451      &            PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
14452
14453 * store 4-momentum of elastically scattered particle (in single diff.
14454 * events)
14455       IF (KP.EQ.0) THEN
14456          DO 7 K=1,4
14457             PSC(K) = PPF(K)
14458     7    CONTINUE
14459       ELSEIF (KT.EQ.0) THEN
14460          DO 8 K=1,4
14461             PSC(K) = PTF(K)
14462     8    CONTINUE
14463       ENDIF
14464
14465 * check consistency of kinematical treatment so far
14466       IF (LEMCCK) THEN
14467          CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
14468          CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
14469          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
14470          IF (IREJ1.NE.0) GOTO 9999
14471       ENDIF
14472       DO 9 K=1,4
14473          DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
14474          DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
14475     9 CONTINUE
14476       IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
14477      &    (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
14478      &    (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
14479      &    (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5))     THEN
14480          WRITE(LOUT,1003) DEV1,DEV2
14481  1003    FORMAT(1X,'DIFEVT:   inconsitent kinematical treatment!  ',
14482      &          2(/,8X,4E12.3))
14483          GOTO 9999
14484       ENDIF
14485
14486 * kinematical treatment for low-mass diffraction
14487       CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
14488       IF (IREJ1.NE.0) GOTO 9999
14489
14490 * dump diffractive chains into DTEVT1
14491       CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14492       IF (IREJ1.NE.0) GOTO 9999
14493
14494       RETURN
14495
14496  9999 CONTINUE
14497       IRDIFF(1) = IRDIFF(1)+1
14498       IREJ      = 1
14499       RETURN
14500       END
14501
14502 *$ CREATE DT_XMHMD.FOR
14503 *COPY DT_XMHMD
14504 *
14505 *===xmhmd==============================================================*
14506 *
14507       DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
14508
14509 ************************************************************************
14510 * Diffractive mass in high mass single/double diffractive events.      *
14511 * This version dated 11.02.95 is written by S. Roesler                 *
14512 ************************************************************************
14513
14514       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14515       SAVE
14516
14517       PARAMETER ( LINP = 10 ,
14518      &            LOUT = 6 ,
14519      &            LDAT = 9 )
14520
14521       PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
14522
14523 * kinematics of diffractive interactions (DTUNUC 1.x)
14524       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14525      &                PPF(4),PTF(4),
14526      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14527      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14528
14529 C     DATA XCOLOW /0.05D0/
14530       DATA XCOLOW /0.15D0/
14531
14532       DT_XMHMD = ZERO
14533       XH = XPH(2)
14534       IF (MODE.EQ.2) XH = XTH(2)
14535
14536 * minimum Pomeron-x for high-mass diffraction
14537 * (adjusted to get a smooth transition between HM and LM component)
14538       R = DT_RNDM(XH)
14539       XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
14540       IF (ECM.LE.300.0D0) THEN
14541          RR     = (1.0D0-EXP(-((ECM/140.0D0)**4)))
14542          XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
14543       ENDIF
14544 * maximum Pomeron-x for high-mass diffraction
14545 * (coherence condition, adjusted to fit to experimental data)
14546       IF (IB.NE.0) THEN
14547 *   baryon-diffraction
14548          XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
14549       ELSE
14550 *   meson-diffraction
14551          XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
14552       ENDIF
14553 * check boundaries
14554       IF (XDIMIN.GE.XDIMAX) THEN
14555          XDIMIN = OHALF*XDIMAX
14556       ENDIF
14557
14558       KLOOP = 0
14559     1 CONTINUE
14560       KLOOP = KLOOP+1
14561       IF (KLOOP.GT.20) RETURN
14562 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
14563       XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
14564 * corr. diffr. mass
14565       DT_XMHMD = ECM*SQRT(XDIFF)
14566       IF (DT_XMHMD.LT.2.5D0) GOTO 1
14567
14568       RETURN
14569       END
14570
14571 *$ CREATE DT_XMLMD.FOR
14572 *COPY DT_XMLMD
14573 *
14574 *===xmlmd==============================================================*
14575 *
14576       DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
14577
14578 ************************************************************************
14579 * Diffractive mass in high mass single/double diffractive events.      *
14580 * This version dated 11.02.95 is written by S. Roesler                 *
14581 ************************************************************************
14582
14583       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14584       SAVE
14585
14586       PARAMETER ( LINP = 10 ,
14587      &            LOUT = 6 ,
14588      &            LDAT = 9 )
14589
14590 * minimum Pomeron-x for low-mass diffraction
14591 C     AMO = 1.5D0
14592       AMO = 2.0D0
14593 * maximum Pomeron-x for low-mass diffraction
14594 * (adjusted to get a smooth transition between HM and LM component)
14595       R   = DT_RNDM(AMO)
14596       SAM = 1.0D0
14597       IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
14598       R   = DT_RNDM(AMO)*SAM
14599       AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
14600       AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
14601
14602 * selection of diffractive mass
14603 * (adjusted to get a smooth transition between HM and LM component)
14604       R   = DT_RNDM(AMU)
14605       IF (ECM.LE.50.0D0) THEN
14606          DT_XMLMD = AMO*(AMU/AMO)**R
14607       ELSE
14608          A = 0.7D0
14609          IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
14610          DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
14611       ENDIF
14612
14613       RETURN
14614       END
14615
14616 *$ CREATE DT_TDIFF.FOR
14617 *COPY DT_TDIFF
14618 *
14619 *===tdiff==============================================================*
14620 *
14621       DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14622
14623 ************************************************************************
14624 * t-selection for single/double diffractive interactions.              *
14625 *          ECM      cm. energy                                         *
14626 *          TMIN     minimum momentum transfer to produce diff. masses  *
14627 *          XM1/XM2  diffractively produced masses                      *
14628 *                   (for single diffraction XM2 is obsolete)           *
14629 *          K1/K2= 0 not excited                                        *
14630 *               = 1 low-mass excitation                                *
14631 *               = 2 high-mass excitation                               *
14632 * This version dated 11.02.95 is written by S. Roesler                 *
14633 ************************************************************************
14634
14635       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14636       SAVE
14637
14638       PARAMETER ( LINP = 10 ,
14639      &            LOUT = 6 ,
14640      &            LDAT = 9 )
14641
14642       PARAMETER (ZERO=0.0D0)
14643
14644       PARAMETER ( BTP0   = 3.7D0,
14645      &            ALPHAP = 0.24D0 )
14646
14647       IREJ   = 0
14648       NCLOOP = 0
14649       DT_TDIFF  = ZERO
14650
14651       IF (K1.GT.0) THEN
14652          XM1 = XM1I
14653          XM2 = XM2I
14654       ELSE
14655          XM1 = XM2I
14656       ENDIF
14657       XDI = (XM1/ECM)**2
14658       IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14659 * slope for single diffraction
14660          SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14661       ELSE
14662 * slope for double diffraction
14663          SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14664       ENDIF
14665
14666     1 CONTINUE
14667       NCLOOP = NCLOOP+1
14668       IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14669       Y = DT_RNDM(XDI)
14670       T = -LOG(1.0D0-Y)/SLOPE
14671       IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14672       DT_TDIFF = -ABS(T)
14673
14674       RETURN
14675
14676  9999 CONTINUE
14677       WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14678  1000 FORMAT(1X,'DT_TDIFF:   t-selection rejected!',/,
14679      &       1X,'ECM  = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14680      &       E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14681       IREJ = 1
14682       RETURN
14683       END
14684
14685 *$ CREATE DT_XVALHM.FOR
14686 *COPY DT_XVALHM
14687 *
14688 *===xvalhm=============================================================*
14689 *
14690       SUBROUTINE DT_XVALHM(KP,KT)
14691
14692 ************************************************************************
14693 * Sampling of parton x-values in high-mass diffractive interactions.   *
14694 * This version dated 12.02.95 is written by S. Roesler                 *
14695 ************************************************************************
14696
14697       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14698       SAVE
14699
14700       PARAMETER ( LINP = 10 ,
14701      &            LOUT = 6 ,
14702      &            LDAT = 9 )
14703
14704       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14705
14706 * kinematics of diffractive interactions (DTUNUC 1.x)
14707       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14708      &                PPF(4),PTF(4),
14709      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14710      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14711
14712 * various options for treatment of partons (DTUNUC 1.x)
14713 * (chain recombination, Cronin,..)
14714       LOGICAL LCO2CR,LINTPT
14715       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14716      &                LCO2CR,LINTPT
14717
14718       DATA UNON,XVQTHR /2.0D0,0.8D0/
14719
14720       IF (KP.EQ.2) THEN
14721 * x-fractions of projectile valence partons
14722     1    CONTINUE
14723          XPH(1) = DT_DBETAR(OHALF,UNON)
14724          IF (XPH(1).GE.XVQTHR) GOTO 1
14725          XPH(2) = ONE-XPH(1)
14726 * x-fractions of Pomeron q-aq-pair
14727          XPOLO = TINY2
14728          XPOHI = ONE-TINY2
14729          XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14730          XPPO(2) = ONE-XPPO(1)
14731 * flavors of Pomeron q-aq-pair
14732          IFLAV    = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14733          IFPPO(1) = IFLAV
14734          IFPPO(2) = -IFLAV
14735          IF (DT_RNDM(UNON).GT.OHALF) THEN
14736             IFPPO(1) = -IFLAV
14737             IFPPO(2) = IFLAV
14738          ENDIF
14739       ENDIF
14740
14741       IF (KT.EQ.2) THEN
14742 * x-fractions of projectile target partons
14743     2    CONTINUE
14744          XTH(1) = DT_DBETAR(OHALF,UNON)
14745          IF (XTH(1).GE.XVQTHR) GOTO 2
14746          XTH(2) = ONE-XTH(1)
14747 * x-fractions of Pomeron q-aq-pair
14748          XPOLO = TINY2
14749          XPOHI = ONE-TINY2
14750          XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14751          XTPO(2) = ONE-XTPO(1)
14752 * flavors of Pomeron q-aq-pair
14753          IFLAV    = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14754          IFTPO(1) = IFLAV
14755          IFTPO(2) = -IFLAV
14756          IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14757             IFTPO(1) = -IFLAV
14758             IFTPO(2) = IFLAV
14759          ENDIF
14760       ENDIF
14761
14762       RETURN
14763       END
14764
14765 *$ CREATE DT_LM2RES.FOR
14766 *COPY DT_LM2RES
14767 *
14768 *===lm2res=============================================================*
14769 *
14770       SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14771
14772 ************************************************************************
14773 * Check low-mass diffractive excitation for resonance mass.            *
14774 *   (input)   IF1/2    PDG-indizes of valence partons                  *
14775 *   (in/out)  XM       diffractive mass requested/corrected            *
14776 *   (output)  IDR/IDXR id./BAMJET-index of resonance                   *
14777 * This version dated 12.02.95 is written by S. Roesler                 *
14778 ************************************************************************
14779
14780       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14781       SAVE
14782
14783       PARAMETER ( LINP = 10 ,
14784      &            LOUT = 6 ,
14785      &            LDAT = 9 )
14786
14787       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14788
14789 * kinematics of diffractive interactions (DTUNUC 1.x)
14790       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14791      &                PPF(4),PTF(4),
14792      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14793      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14794
14795       IREJ = 0
14796       IF1B = 0
14797       IF2B = 0
14798       XMI  = XM
14799
14800 * BAMJET indices of partons
14801       IF1A = IDT_IPDG2B(IF1,1,2)
14802       IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14803       IF2A = IDT_IPDG2B(IF2,1,2)
14804       IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14805
14806 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14807       IDCH = 2
14808       IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14809
14810 * check for resonance mass
14811       CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14812       IF (IREJ1.NE.0) GOTO 9999
14813
14814       XM = XMN
14815       RETURN
14816
14817  9999 CONTINUE
14818       IREJ = 1
14819       RETURN
14820       END
14821
14822 *$ CREATE DT_LMKINE.FOR
14823 *COPY DT_LMKINE
14824 *
14825 *===lmkine=============================================================*
14826 *
14827       SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14828
14829 ************************************************************************
14830 * Kinematical treatment of low-mass excitations.                       *
14831 * This version dated 12.02.95 is written by S. Roesler                 *
14832 ************************************************************************
14833
14834       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14835       SAVE
14836
14837       PARAMETER ( LINP = 10 ,
14838      &            LOUT = 6 ,
14839      &            LDAT = 9 )
14840
14841       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14842
14843 * flags for input different options
14844       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14845       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14846      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14847
14848 * kinematics of diffractive interactions (DTUNUC 1.x)
14849       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14850      &                PPF(4),PTF(4),
14851      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14852      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14853
14854       DIMENSION P1(4),P2(4)
14855
14856       IREJ = 0
14857
14858       IF (KP.EQ.1) THEN
14859          PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14860          POE  = PPF(4)/PABS
14861          FAC1 = OHALF*(POE+ONE)
14862          FAC2 = -OHALF*(POE-ONE)
14863          DO 1 K=1,3
14864             PPLM1(K) = FAC1*PPF(K)
14865             PPLM2(K) = FAC2*PPF(K)
14866     1    CONTINUE
14867          PPLM1(4) = FAC1*PABS
14868          PPLM2(4) = -FAC2*PABS
14869          IF (IMSHL.EQ.1) THEN
14870
14871             XM1 = PYMASS(IFP1)
14872             XM2 = PYMASS(IFP2)
14873
14874             CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14875             IF (IREJ1.NE.0) GOTO 9999
14876             DO 2 K=1,4
14877                PPLM1(K) = P1(K)
14878                PPLM2(K) = P2(K)
14879     2       CONTINUE
14880          ENDIF
14881       ENDIF
14882
14883       IF (KT.EQ.1) THEN
14884          PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14885          POE  = PTF(4)/PABS
14886          FAC1 = OHALF*(POE+ONE)
14887          FAC2 = -OHALF*(POE-ONE)
14888          DO 3 K=1,3
14889             PTLM2(K) = FAC1*PTF(K)
14890             PTLM1(K) = FAC2*PTF(K)
14891     3    CONTINUE
14892          PTLM2(4) = FAC1*PABS
14893          PTLM1(4) = -FAC2*PABS
14894          IF (IMSHL.EQ.1) THEN
14895
14896             XM1 = PYMASS(IFT1)
14897             XM2 = PYMASS(IFT2)
14898
14899             CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14900             IF (IREJ1.NE.0) GOTO 9999
14901             DO 4 K=1,4
14902                PTLM1(K) = P1(K)
14903                PTLM2(K) = P2(K)
14904     4       CONTINUE
14905          ENDIF
14906       ENDIF
14907
14908       RETURN
14909
14910  9999 CONTINUE
14911       WRITE(LOUT,'(A)') 'LMKINE:   kinematical treatment rejected'
14912       IREJ = 1
14913       RETURN
14914       END
14915
14916 *$ CREATE DT_DIFINI.FOR
14917 *COPY DT_DIFINI
14918 *
14919 *===difini=============================================================*
14920 *
14921       SUBROUTINE DT_DIFINI
14922
14923 ************************************************************************
14924 * Initialization of common /DTDIKI/                                    *
14925 * This version dated 12.02.95 is written by S. Roesler                 *
14926 ************************************************************************
14927
14928       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14929       SAVE
14930
14931       PARAMETER ( LINP = 10 ,
14932      &            LOUT = 6 ,
14933      &            LDAT = 9 )
14934
14935       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14936
14937 * kinematics of diffractive interactions (DTUNUC 1.x)
14938       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14939      &                PPF(4),PTF(4),
14940      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14941      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14942
14943       DO 1 K=1,4
14944          PPOM(K)  = ZERO
14945          PSC(K)   = ZERO
14946          PPF(K)   = ZERO
14947          PTF(K)   = ZERO
14948          PPLM1(K) = ZERO
14949          PPLM2(K) = ZERO
14950          PTLM1(K) = ZERO
14951          PTLM2(K) = ZERO
14952     1 CONTINUE
14953       DO 2 K=1,2
14954          XPH(K)   = ZERO
14955          XPPO(K)  = ZERO
14956          XTH(K)   = ZERO
14957          XTPO(K)  = ZERO
14958          IFPPO(K) = 0
14959          IFTPO(K) = 0
14960     2 CONTINUE
14961       IDPR  = 0
14962       IDXPR = 0
14963       IDTR  = 0
14964       IDXTR = 0
14965
14966       RETURN
14967       END
14968
14969 *$ CREATE DT_DIFPUT.FOR
14970 *COPY DT_DIFPUT
14971 *
14972 *===difput=============================================================*
14973 *
14974       SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14975      &                                                          IREJ)
14976
14977 ************************************************************************
14978 * Dump diffractive chains into DTEVT1                                  *
14979 * This version dated 12.02.95 is written by S. Roesler                 *
14980 ************************************************************************
14981
14982       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14983       SAVE
14984
14985       PARAMETER ( LINP = 10 ,
14986      &            LOUT = 6 ,
14987      &            LDAT = 9 )
14988
14989       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14990
14991       LOGICAL LCHK
14992
14993 * kinematics of diffractive interactions (DTUNUC 1.x)
14994       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14995      &                PPF(4),PTF(4),
14996      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14997      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14998
14999 * event history
15000
15001       PARAMETER (NMXHKK=200000)
15002
15003       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15004      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15005      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15006
15007 * extended event history
15008       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15009      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15010      &                IHIST(2,NMXHKK)
15011
15012 * rejection counter
15013       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
15014      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
15015      &                IREXCI(3),IRDIFF(2),IRINC
15016
15017       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
15018      &          P1(4),P2(4),P3(4),P4(4)
15019
15020       IREJ = 0
15021
15022       IF (KP.EQ.1) THEN
15023          DO 1 K=1,4
15024             PCH(K) = PPLM1(K)+PPLM2(K)
15025     1    CONTINUE
15026          ID1 = IFP1
15027          ID2 = IFP2
15028          IF (DT_RNDM(PT).GT.OHALF) THEN
15029             ID1 = IFP2
15030             ID2 = IFP1
15031          ENDIF
15032          CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
15033      &                                        PPLM1(4),0,0,0)
15034          CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
15035      &                                        PPLM2(4),0,0,0)
15036          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15037      &                                              IDPR,IDXPR,8)
15038       ELSEIF (KP.EQ.2) THEN
15039          DO 2 K=1,4
15040             PP1(K) = XPH(1)*PP(K)
15041             PP2(K) = XPH(2)*PP(K)
15042             PT1(K) = -XPPO(1)*PPOM(K)
15043             PT2(K) = -XPPO(2)*PPOM(K)
15044     2    CONTINUE
15045          CALL  DT_CHKCSY(IFP1,IFPPO(1),LCHK)
15046          XM1 = ZERO
15047          XM2 = ZERO
15048          IF (LCHK) THEN
15049             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15050             IF (IREJ1.NE.0) GOTO 9999
15051             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15052             IF (IREJ1.NE.0) GOTO 9999
15053             DO 3 K=1,4
15054                PP1(K) = P1(K)
15055                PT1(K) = P2(K)
15056                PP2(K) = P3(K)
15057                PT2(K) = P4(K)
15058     3       CONTINUE
15059             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15060      &                                                       0,0,8)
15061             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15062      &                                             PT1(4),0,0,8)
15063             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15064      &                                                       0,0,8)
15065             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15066      &                                             PT2(4),0,0,8)
15067          ELSE
15068             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15069             IF (IREJ1.NE.0) GOTO 9999
15070             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15071             IF (IREJ1.NE.0) GOTO 9999
15072             DO 4 K=1,4
15073                PP1(K) = P1(K)
15074                PT2(K) = P2(K)
15075                PP2(K) = P3(K)
15076                PT1(K) = P4(K)
15077     4       CONTINUE
15078             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15079      &                                                       0,0,8)
15080             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15081      &                                                PT2(4),0,0,8)
15082             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15083      &                                                       0,0,8)
15084             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15085      &                                                PT1(4),0,0,8)
15086          ENDIF
15087          NCSY = NCSY+1
15088       ELSE
15089          CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
15090      &                                                        0,0,0)
15091       ENDIF
15092
15093       IF (KT.EQ.1) THEN
15094          DO 5 K=1,4
15095             PCH(K) = PTLM1(K)+PTLM2(K)
15096     5    CONTINUE
15097          ID1 = IFT1
15098          ID2 = IFT2
15099          IF (DT_RNDM(PT).GT.OHALF) THEN
15100             ID1 = IFT2
15101             ID2 = IFT1
15102          ENDIF
15103          CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
15104      &                                              PTLM1(4),0,0,0)
15105          CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
15106      &                                              PTLM2(4),0,0,0)
15107          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15108      &                                              IDTR,IDXTR,8)
15109       ELSEIF (KT.EQ.2) THEN
15110          DO 6 K=1,4
15111             PP1(K) = XTPO(1)*PPOM(K)
15112             PP2(K) = XTPO(2)*PPOM(K)
15113             PT1(K) = XTH(2)*PT(K)
15114             PT2(K) = XTH(1)*PT(K)
15115     6    CONTINUE
15116          CALL  DT_CHKCSY(IFTPO(1),IFT1,LCHK)
15117          XM1 = ZERO
15118          XM2 = ZERO
15119          IF (LCHK) THEN
15120             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15121             IF (IREJ1.NE.0) GOTO 9999
15122             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15123             IF (IREJ1.NE.0) GOTO 9999
15124             DO 7 K=1,4
15125                PP1(K) = P1(K)
15126                PT1(K) = P2(K)
15127                PP2(K) = P3(K)
15128                PT2(K) = P4(K)
15129     7       CONTINUE
15130             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15131      &                                                PP1(4),0,0,8)
15132             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15133      &                                                       0,0,8)
15134             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15135      &                                                PP2(4),0,0,8)
15136             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15137      &                                                       0,0,8)
15138          ELSE
15139             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15140             IF (IREJ1.NE.0) GOTO 9999
15141             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15142             IF (IREJ1.NE.0) GOTO 9999
15143             DO 8 K=1,4
15144                PP1(K) = P1(K)
15145                PT2(K) = P2(K)
15146                PP2(K) = P3(K)
15147                PT1(K) = P4(K)
15148     8       CONTINUE
15149             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15150      &                                                PP1(4),0,0,8)
15151             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15152      &                                                       0,0,8)
15153             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15154      &                                                PP2(4),0,0,8)
15155             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15156      &                                                       0,0,8)
15157          ENDIF
15158          NCSY = NCSY+1
15159       ELSE
15160          CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
15161      &                                                        0,0,0)
15162       ENDIF
15163
15164       RETURN
15165
15166  9999 CONTINUE
15167       IRDIFF(2) = IRDIFF(2)+1
15168       IREJ      = 1
15169       RETURN
15170       END
15171 *$ CREATE DT_EVTFRG.FOR
15172 *COPY DT_EVTFRG
15173 *
15174 *===evtfrg=============================================================*
15175 *
15176       SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
15177
15178 ************************************************************************
15179 * Hadronization of chains in DTEVT1.                                   *
15180 *                                                                      *
15181 * Input:                                                               *
15182 *   KMODE = 1   hadronization of PHOJET-chains (id=77xxx)              *
15183 *         = 2   hadronization of DTUNUC-chains (id=88xxx)              *
15184 *   NFRG  if KMODE = 1 : upper index of PHOJET-scatterings to be       *
15185 *                        hadronized with one PYEXEC call               *
15186 *         if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
15187 *                        with one PYEXEC call                          *
15188 * Output:                                                              *
15189 *   NPYMEM      number of entries in JETSET-common after hadronization *
15190 *   IREJ        rejection flag                                         *
15191 *                                                                      *
15192 * This version dated 17.09.00 is written by S. Roesler                 *
15193 ************************************************************************
15194
15195       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15196       SAVE
15197
15198       PARAMETER ( LINP = 10 ,
15199      &            LOUT = 6 ,
15200      &            LDAT = 9 )
15201
15202       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
15203       PARAMETER (ONE=1.0D0,ZERO=0.0D0)
15204
15205       LOGICAL LACCEP
15206
15207       PARAMETER (MXJOIN=200)
15208
15209 * event history
15210
15211       PARAMETER (NMXHKK=200000)
15212
15213       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15214      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15215      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15216
15217 * extended event history
15218       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15219      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15220      &                IHIST(2,NMXHKK)
15221
15222 * flags for input different options
15223       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15224       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15225      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15226
15227 * statistics
15228       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
15229      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
15230      &                ICEVTG(8,0:30)
15231
15232 * flags for diffractive interactions (DTUNUC 1.x)
15233       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
15234
15235 * nucleon-nucleon event-generator
15236       CHARACTER*8 CMODEL
15237       LOGICAL LPHOIN
15238       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
15239 * phojet
15240
15241 C  model switches and parameters
15242       CHARACTER*8 MDLNA
15243       INTEGER ISWMDL,IPAMDL
15244       DOUBLE PRECISION PARMDL
15245       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15246 * jetset
15247
15248       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15249       PARAMETER (MAXLND=4000)
15250       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15251
15252       INTEGER PYK
15253
15254       DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
15255
15256       MODE = KMODE
15257       ISTSTG = 7
15258       IF (MODE.NE.1) ISTSTG = 8
15259       IREJ = 0
15260
15261       IP     = 0
15262       ISH    = 0
15263       INIEMC = 1
15264       NEND   = NHKK
15265       NACCEP = 0
15266       IFRG   = 0
15267       IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
15268       DO 10 I=NPOINT(3),NEND
15269 * sr 14.02.00: seems to be not necessary anymore, commented
15270 C        LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
15271 C    &            ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
15272          LACCEP = .TRUE.
15273 * pick up chains from dtevt1
15274          IDCHK = IDHKK(I)/10000
15275          IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
15276             IF (IDCHK.EQ.7) THEN
15277                IPJE = IDHKK(I)-IDCHK*10000
15278                IF (IPJE.NE.IFRG) THEN
15279                   IFRG = IPJE
15280                   IF (IFRG.GT.NFRG) GOTO 16
15281                ENDIF
15282             ELSE
15283                IPJE = 1
15284                IFRG = IFRG+1
15285                IF (IFRG.GT.NFRG) THEN
15286                   NFRG = -1
15287                   GOTO 16
15288                ENDIF
15289             ENDIF
15290 *   statistics counter
15291 c           IF (IDCH(I).LE.8)
15292 c    &         ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
15293 c           IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
15294 * special treatment for small chains already corrected to hadrons
15295             IF (IDRES(I).NE.0) THEN
15296                IF (IDRES(I).EQ.11) THEN
15297                   ID = IDXRES(I)
15298                ELSE
15299                   ID = IDT_IPDGHA(IDXRES(I))
15300                ENDIF
15301                IF (LEMCCK) THEN
15302                   CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15303      &                              PHKK(4,I),INIEMC,IDUM,IDUM)
15304                   INIEMC = 2
15305                ENDIF
15306                IP = IP+1
15307                IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
15308                P(IP,1) = PHKK(1,I)
15309                P(IP,2) = PHKK(2,I)
15310                P(IP,3) = PHKK(3,I)
15311                P(IP,4) = PHKK(4,I)
15312                P(IP,5) = PHKK(5,I)
15313                K(IP,1) = 1
15314                K(IP,2) = ID
15315                K(IP,3) = 0
15316                K(IP,4) = 0
15317                K(IP,5) = 0
15318                IHIST(2,I) = 10000*IPJE+IP
15319                IF (IHIST(1,I).LE.-100) THEN
15320                   ISH = ISH+1
15321                   IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15322                   ISJOIN(ISH) = I
15323                ENDIF
15324                N = IP
15325                IHISMO(IP) = I
15326             ELSE
15327                IJ  = 0
15328                DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
15329                   IF (LEMCCK) THEN
15330                      CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
15331      &                                   PHKK(4,KK),INIEMC,IDUM,IDUM)
15332                      CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
15333                      INIEMC = 2
15334                   ENDIF
15335                   ID = IDHKK(KK)
15336                   IF (ID.EQ.0) ID = 21
15337 c                  PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
15338 c                  AM0  = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
15339
15340 c                  AMRQ   = PYMASS(ID)
15341
15342 c                  AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
15343 c                  IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
15344 c     &                (ABS(IDIFF).EQ.0)) THEN
15345 cC                    WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
15346 c                     DELTA      = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
15347 c                     PHKK(4,KK) = PHKK(4,KK)+DELTA
15348 c                     PTOT1      = PTOT-DELTA
15349 c                     PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
15350 c                     PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
15351 c                     PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
15352 c                     PHKK(5,KK) = AMRQ
15353 c                  ENDIF
15354                   IP = IP+1
15355                   IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
15356                   P(IP,1) = PHKK(1,KK)
15357                   P(IP,2) = PHKK(2,KK)
15358                   P(IP,3) = PHKK(3,KK)
15359                   P(IP,4) = PHKK(4,KK)
15360                   P(IP,5) = PHKK(5,KK)
15361                   K(IP,1) = 1
15362                   K(IP,2) = ID
15363                   K(IP,3) = 0
15364                   K(IP,4) = 0
15365                   K(IP,5) = 0
15366                   IHIST(2,KK) = 10000*IPJE+IP
15367                   IF (IHIST(1,KK).LE.-100) THEN
15368                      ISH = ISH+1
15369                      IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15370                      ISJOIN(ISH) = KK
15371                   ENDIF
15372                   IJ = IJ+1
15373                   IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
15374                   IJOIN(IJ)  = IP
15375                   IHISMO(IP) = I
15376    11          CONTINUE
15377                N = IP
15378 * join the two-parton system
15379
15380                CALL PYJOIN(IJ,IJOIN)
15381
15382             ENDIF
15383             IDHKK(I) = 99999
15384          ENDIF
15385    10 CONTINUE
15386    16 CONTINUE
15387       N = IP
15388
15389       IF (IP.GT.0) THEN
15390
15391 * final state parton shower
15392          DO 136 NPJE=1,IPJE
15393             IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
15394                IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
15395                   DO 130 K1=1,ISH
15396                      IF (ISJOIN(K1).EQ.0) GOTO 130
15397                      I = ISJOIN(K1)
15398                      IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
15399      &                                                       GOTO 130
15400                      IH1 = IHIST(2,I)/10000
15401                      IF (IH1.NE.NPJE) GOTO 130
15402                      IH1 = IHIST(2,I)-IH1*10000
15403                      DO 135 K2=K1+1,ISH
15404                         IF (ISJOIN(K2).EQ.0) GOTO 135
15405                         II = ISJOIN(K2)
15406                         IH2 = IHIST(2,II)/10000
15407                         IF (IH2.NE.NPJE) GOTO 135
15408                         IH2 = IHIST(2,II)-IH2*10000
15409                         IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
15410                            PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
15411                            PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
15412
15413                            RQLUN = MIN(PT1,PT2)
15414                            CALL PYSHOW(IH1,IH2,RQLUN)
15415
15416                            ISJOIN(K1) = 0
15417                            ISJOIN(K2) = 0
15418                            GOTO 130
15419                         ENDIF
15420  135                 CONTINUE
15421  130              CONTINUE
15422                ENDIF
15423             ENDIF
15424  136     CONTINUE
15425
15426          CALL DT_INITJS(MODE)
15427 * hadronization
15428
15429          CALL PYEXEC
15430
15431          IF (MSTU(24).NE.0) THEN
15432             WRITE(LOUT,*) ' JETSET-reject at event',
15433      &                    NEVHKK,MSTU(24),KMODE
15434 C           CALL DT_EVTOUT(4)
15435
15436 C           CALL PYLIST(2)
15437
15438             GOTO 9999
15439          ENDIF
15440
15441 *   number of entries in LUJETS
15442
15443          NLINES = PYK(0,1)
15444
15445          NPYMEM = NLINES
15446
15447          DO 12 I=1,NLINES
15448             IFLG(I) = 0
15449    12    CONTINUE
15450
15451          DO 13 II=1,NLINES
15452
15453             IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
15454
15455 *  pick up mother resonance if possible and put it together with
15456 *  their decay-products into the common
15457                IDXMOR = K(II,3)
15458                IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
15459                   KFMOR = K(IDXMOR,2)
15460                   ISMOR = K(IDXMOR,1)
15461                ELSE
15462                   KFMOR = 91
15463                   ISMOR = 1
15464                ENDIF
15465                IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
15466      &             (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
15467                   ID = K(IDXMOR,2)
15468                   MO = IHISMO(PYK(IDXMOR,15))
15469                   PX = PYP(IDXMOR,1)
15470                   PY = PYP(IDXMOR,2)
15471                   PZ = PYP(IDXMOR,3)
15472                   PE = PYP(IDXMOR,4)
15473
15474                   CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15475                   IFLG(IDXMOR) = 1
15476                   MO = NHKK
15477                   DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
15478                      IF (PYK(JDAUG,7).EQ.1) THEN
15479                         ID = PYK(JDAUG,8)
15480                         PX = PYP(JDAUG,1)
15481                         PY = PYP(JDAUG,2)
15482                         PZ = PYP(JDAUG,3)
15483                         PE = PYP(JDAUG,4)
15484
15485                         CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15486                         IF (LEMCCK) THEN
15487                            PX = -PYP(JDAUG,1)
15488                            PY = -PYP(JDAUG,2)
15489                            PZ = -PYP(JDAUG,3)
15490                            PE = -PYP(JDAUG,4)
15491
15492                            CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15493                         ENDIF
15494                         IFLG(JDAUG) = 1
15495                      ENDIF
15496    15             CONTINUE
15497                ELSE
15498 *  there was no mother resonance
15499                   MO = IHISMO(PYK(II,15))
15500                   ID = PYK(II,8)
15501                   PX = PYP(II,1)
15502                   PY = PYP(II,2)
15503                   PZ = PYP(II,3)
15504                   PE = PYP(II,4)
15505
15506                   CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15507                   IF (LEMCCK) THEN
15508                      PX = -PYP(II,1)
15509                      PY = -PYP(II,2)
15510                      PZ = -PYP(II,3)
15511                      PE = -PYP(II,4)
15512
15513                      CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15514                   ENDIF
15515                ENDIF
15516             ENDIF
15517    13    CONTINUE
15518          IF (LEMCCK) THEN
15519             CHKLEV = TINY1
15520             CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
15521 C           IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
15522          ENDIF
15523
15524 * global energy-momentum & flavor conservation check
15525 **sr 16.5. this check is skipped in case of phojet-treatment
15526          IF (MCGENE.EQ.1)
15527      &      CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
15528
15529 * update statistics-counter for diffraction
15530 c        IF (IFLAGD.NE.0) THEN
15531 c           ICDIFF(1) = ICDIFF(1)+1
15532 c           IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
15533 c           IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
15534 c           IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
15535 c           IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
15536 c        ENDIF
15537
15538       ENDIF
15539
15540       RETURN
15541
15542  9999 CONTINUE
15543       IREJ = 1
15544       RETURN
15545       END
15546
15547 *$ CREATE DT_DECAYS.FOR
15548 *COPY DT_DECAYS
15549 *
15550 *===decay==============================================================*
15551 *
15552       SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15553
15554 ************************************************************************
15555 * Resonance-decay.                                                     *
15556 * This subroutine replaces DDECAY/DECHKK.                              *
15557 *             PIN(4)      4-momentum of resonance          (input)     *
15558 *             IDXIN       BAMJET-index of resonance        (input)     *
15559 *             POUT(20,4)  4-momenta of decay-products      (output)    *
15560 *             IDXOUT(20)  BAMJET-indices of decay-products (output)    *
15561 *             NSEC        number of secondaries            (output)    *
15562 * Adopted from the original version DECHKK.                            *
15563 * This version dated 09.01.95 is written by S. Roesler                 *
15564 ************************************************************************
15565
15566       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15567       SAVE
15568
15569       PARAMETER ( LINP = 10 ,
15570      &            LOUT = 6 ,
15571      &            LDAT = 9 )
15572
15573       PARAMETER (TINY17=1.0D-17)
15574
15575 * HADRIN: decay channel information
15576       PARAMETER (IDMAX9=602)
15577       CHARACTER*8 ZKNAME
15578       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15579
15580 * particle properties (BAMJET index convention)
15581       CHARACTER*8  ANAME
15582       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15583      &                IICH(210),IIBAR(210),K1(210),K2(210)
15584
15585 * flags for input different options
15586       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15587       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15588      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15589
15590       DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
15591      &          EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
15592      &          CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
15593
15594 * ISTAB = 1 strong and weak decays
15595 *       = 2 strong decays only
15596 *       = 3 strong decays, weak decays for charmed particles and tau
15597 *           leptons only
15598       DATA ISTAB /2/
15599
15600       IREJ = 0
15601       NSEC = 0
15602 * put initial resonance to stack
15603       NSTK = 1
15604       IDXSTK(NSTK) = IDXIN
15605       DO 5 I=1,4
15606          PI(NSTK,I) = PIN(I)
15607     5 CONTINUE
15608
15609 * store initial configuration for energy-momentum cons. check
15610       IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
15611      &                                   PI(NSTK,4),1,IDUM,IDUM)
15612
15613   100 CONTINUE
15614 * get particle from stack
15615       IDXI = IDXSTK(NSTK)
15616 * skip stable particles
15617       IF (ISTAB.EQ.1) THEN
15618          IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
15619          IF ((IDXI.GE.  1).AND.(IDXI.LE.  7)) GOTO 10
15620       ELSEIF (ISTAB.EQ.2) THEN
15621          IF ((IDXI.GE.  1).AND.(IDXI.LE. 30)) GOTO 10
15622          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15623          IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
15624          IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
15625          IF ( IDXI.EQ.109)                    GOTO 10
15626          IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
15627       ELSEIF (ISTAB.EQ.3) THEN
15628          IF ((IDXI.GE.  1).AND.(IDXI.LE. 23)) GOTO 10
15629          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15630          IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
15631          IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
15632       ENDIF
15633
15634 * calculate direction cosines and Lorentz-parameter of decaying part.
15635       PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
15636       PTOT = MAX(PTOT,TINY17)
15637       DO 1 I=1,3
15638          DCOS(I) = PI(NSTK,I)/PTOT
15639     1 CONTINUE
15640       GAM  = PI(NSTK,4)/AAM(IDXI)
15641       BGAM = PTOT/AAM(IDXI)
15642
15643 * get decay-channel
15644       KCHAN = K1(IDXI)-1
15645     2 CONTINUE
15646       KCHAN = KCHAN+1
15647       IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
15648
15649 * identities of secondaries
15650       IDX(1) = NZK(KCHAN,1)
15651       IDX(2) = NZK(KCHAN,2)
15652       IF (IDX(2).LT.1) GOTO 9999
15653       IDX(3) = NZK(KCHAN,3)
15654
15655 * handle decay in rest system of decaying particle
15656       IF (IDX(3).EQ.0) THEN
15657 *   two-particle decay
15658          NDEC = 2
15659          CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
15660      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15661      &               AAM(IDX(1)),AAM(IDX(2)))
15662       ELSE
15663 *   three-particle decay
15664          NDEC = 3
15665          CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
15666      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15667      &               CODF(3),COFF(3),SIFF(3),
15668      &               AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15669       ENDIF
15670       NSTK = NSTK-1
15671
15672 * transform decay products back
15673       DO 3 I=1,NDEC
15674          NSTK = NSTK+1
15675          CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15676      &               CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15677      &               PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15678 * add particle to stack
15679          IDXSTK(NSTK) = IDX(I)
15680          DO 4 J=1,3
15681             PI(NSTK,J) = DCOSF(J)*PFF(I)
15682     4    CONTINUE
15683     3 CONTINUE
15684       GOTO 100
15685
15686    10 CONTINUE
15687 * stable particle, put to output-arrays
15688       NSEC = NSEC+1
15689       DO 6 I=1,4
15690          POUT(NSEC,I) = PI(NSTK,I)
15691     6 CONTINUE
15692       IDXOUT(NSEC) = IDXSTK(NSTK)
15693 * store secondaries for energy-momentum conservation check
15694       IF (LEMCCK)
15695      &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15696      &            -POUT(NSEC,4),2,IDUM,IDUM)
15697       NSTK = NSTK-1
15698       IF (NSTK.GT.0) GOTO 100
15699
15700 * check energy-momentum conservation
15701       IF (LEMCCK) THEN
15702          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15703          IF (IREJ1.NE.0) GOTO 9999
15704       ENDIF
15705
15706       RETURN
15707
15708  9999 CONTINUE
15709       IREJ = 1
15710       RETURN
15711       END
15712
15713 *$ CREATE DT_DECAY1.FOR
15714 *COPY DT_DECAY1
15715 *
15716 *===decay1=============================================================*
15717 *
15718       SUBROUTINE DT_DECAY1
15719
15720 ************************************************************************
15721 * Decay of resonances stored in DTEVT1.                                *
15722 * This version dated 20.01.95 is written by S. Roesler                 *
15723 ************************************************************************
15724
15725       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15726       SAVE
15727
15728       PARAMETER ( LINP = 10 ,
15729      &            LOUT = 6 ,
15730      &            LDAT = 9 )
15731
15732 * event history
15733
15734       PARAMETER (NMXHKK=200000)
15735
15736       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15737      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15738      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15739
15740 * extended event history
15741       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15742      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15743      &                IHIST(2,NMXHKK)
15744
15745       DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15746
15747       NEND = NHKK
15748 C     DO 1 I=NPOINT(5),NEND
15749       DO 1 I=NPOINT(4),NEND
15750          IF (ABS(ISTHKK(I)).EQ.1) THEN
15751             DO 2 K=1,4
15752                PIN(K) = PHKK(K,I)
15753     2       CONTINUE
15754             IDXIN = IDBAM(I)
15755             CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15756             IF (NSEC.GT.1) THEN
15757                DO 3 N=1,NSEC
15758                   IDHAD = IDT_IPDGHA(IDXOUT(N))
15759                   CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15760      &                               POUT(N,3),POUT(N,4),0,0,0)
15761     3          CONTINUE
15762             ENDIF
15763          ENDIF
15764     1 CONTINUE
15765
15766       RETURN
15767       END
15768
15769 *$ CREATE DT_DECPI0.FOR
15770 *COPY DT_DECPI0
15771 *
15772 *===decpi0=============================================================*
15773 *
15774       SUBROUTINE DT_DECPI0
15775
15776 ************************************************************************
15777 * Decay of pi0 handled with JETSET.                                    *
15778 * This version dated 18.02.96 is written by S. Roesler                 *
15779 ************************************************************************
15780
15781       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15782       SAVE
15783
15784       PARAMETER ( LINP = 10 ,
15785      &            LOUT = 6 ,
15786      &            LDAT = 9 )
15787
15788       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15789
15790 * event history
15791
15792       PARAMETER (NMXHKK=200000)
15793
15794       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15795      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15796      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15797
15798 * extended event history
15799       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15800      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15801      &                IHIST(2,NMXHKK)
15802
15803       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15804       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15805       PARAMETER (MAXLND=4000)
15806       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15807
15808 * flags for input different options
15809       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15810       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15811      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15812
15813       INTEGER PYCOMP,PYK
15814
15815       DIMENSION IHISMO(NMXHKK),P1(4)
15816
15817       TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15818
15819       CALL DT_INITJS(2)
15820 * allow pi0 decay
15821
15822       KC = PYCOMP(111)
15823
15824       MDCY(KC,1) = 1
15825
15826       NN  = 0
15827       INI = 0
15828       DO 1 I=1,NHKK
15829          IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15830             IF (INI.EQ.0) THEN
15831                INI = 1
15832             ELSE
15833                INI = 2
15834             ENDIF
15835             IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15836      &                                    PHKK(4,I),INI,IDUM,IDUM)
15837             PT    = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15838             PTOT  = SQRT(PT**2+PHKK(3,I)**2)
15839             COSTH = PHKK(3,I)/(PTOT+TINY10)
15840             IF (COSTH.GT.ONE) THEN
15841                THETA = ZERO
15842             ELSEIF (COSTH.LT.-ONE) THEN
15843                THETA = TWOPI/2.0D0
15844             ELSE
15845                THETA = ACOS(COSTH)
15846             ENDIF
15847             PHI     = ASIN(PHKK(2,I)/(PT  +TINY10))
15848             IF (PHKK(1,I).LT.0.0D0)
15849
15850      &         PHI  = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15851
15852             ENER    = PHKK(4,I)
15853             NN      = NN+1
15854             KTEMP   = MSTU(10)
15855             MSTU(10)= 1
15856             P(NN,5) = PHKK(5,I)
15857
15858             CALL PY1ENT(NN,111,ENER,THETA,PHI)
15859
15860             MSTU(10)  = KTEMP
15861             IHISMO(NN)= I
15862          ENDIF
15863     1 CONTINUE
15864       IF (NN.GT.0) THEN
15865
15866          CALL PYEXEC
15867
15868          NLINES = PYK(0,1)
15869
15870          DO 2 II=1,NLINES
15871
15872             IF (PYK(II,7).EQ.1) THEN
15873
15874                DO 3 KK=1,4
15875
15876                   P1(KK) = PYP(II,KK)
15877
15878     3          CONTINUE
15879
15880                ID = PYK(II,8)
15881                MO = IHISMO(PYK(II,15))
15882
15883                CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15884                IF (LEMCCK)
15885      &            CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15886      &                                            IDUM,IDUM)
15887 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15888                ISTHKK(MO) = -2
15889             ENDIF
15890     2    CONTINUE
15891          IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15892       ENDIF
15893       MDCY(KC,1) = 0
15894
15895       RETURN
15896       END
15897
15898 *$ CREATE DT_DTWOPD.FOR
15899 *COPY DT_DTWOPD
15900 *
15901 *===dtwopd=============================================================*
15902 *
15903       SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15904      &                                            COF2,SIF2,AM1,AM2)
15905
15906 ************************************************************************
15907 * Two-particle decay.                                                  *
15908 *  UMO                 cm-energy of the decaying system       (input)  *
15909 *  AM1/AM2             masses of the decay products           (input)  *
15910 *  ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15911 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15912 * Revised by S. Roesler, 20.11.95                                      *
15913 ************************************************************************
15914
15915       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15916       SAVE
15917
15918       PARAMETER ( LINP = 10 ,
15919      &            LOUT = 6 ,
15920      &            LDAT = 9 )
15921
15922       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15923
15924       IF (UMO.LT.(AM1+AM2)) THEN
15925          WRITE(LOUT,1000) UMO,AM1,AM2
15926  1000    FORMAT(1X,'DTWOPD:    inconsistent kinematics - UMO,AM1,AM2 ',
15927      &          3E12.3)
15928          STOP
15929       ENDIF
15930
15931       ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15932       ECM2 = UMO-ECM1
15933       PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15934       PCM2 = PCM1
15935       CALL DT_DSFECF(SIF1,COF1)
15936       COD1 = TWO*DT_RNDM(PCM2)-ONE
15937       COD2 = -COD1
15938       COF2 = -COF1
15939       SIF2 = -SIF1
15940
15941       RETURN
15942       END
15943
15944 *$ CREATE DT_DTHREP.FOR
15945 *COPY DT_DTHREP
15946 *
15947 *===dthrep=============================================================*
15948 *
15949       SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15950      &                  SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15951
15952 ************************************************************************
15953 * Three-particle decay.                                                *
15954 *  UMO                 cm-energy of the decaying system       (input)  *
15955 *  AM1/2/3             masses of the decay products           (input)  *
15956 *  ECM1/2/2,PCM1/2/3   cm-energies/momenta of the decay prod. (output) *
15957 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15958 *                                                                      *
15959 * Threpd89: slight revision by A. Ferrari                              *
15960 * Last change on   11-oct-93   by    Alfredo Ferrari, INFN - Milan     *
15961 * Revised by S. Roesler, 20.11.95                                      *
15962 ************************************************************************
15963
15964       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15965       SAVE
15966
15967       PARAMETER ( LINP = 10 ,
15968      &            LOUT = 6 ,
15969      &            LDAT = 9 )
15970
15971       PARAMETER ( ANGLSQ = 2.5D-31 )
15972       PARAMETER ( AZRZRZ = 1.0D-30 )
15973       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
15974       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
15975       PARAMETER ( ONEONE = 1.D+00 )
15976       PARAMETER ( TWOTWO = 2.D+00 )
15977       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15978
15979       COMMON /HNGAMR/ REDU,AMO,AMM(15)
15980
15981 * flags for input different options
15982       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15983       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15984      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15985
15986       DIMENSION F(5),XX(5)
15987       DATA EPS /AZRZRZ/
15988
15989       UMOO=UMO+UMO
15990 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
15991 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
15992 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
15993       UUMO=UMO
15994       AAM1=AM1
15995       AAM2=AM2
15996       AAM3=AM3
15997       GU=(AM2+AM3)**2
15998       GO=(UMO-AM1)**2
15999 *     UFAK=1.0000000000001D0
16000 *     IF (GU.GT.GO) UFAK=0.9999999999999D0
16001       IF (GU.GT.GO) THEN
16002          UFAK=ONEMNS
16003       ELSE
16004          UFAK=ONEPLS
16005       END IF
16006       OFAK=2.D0-UFAK
16007       GU=GU*UFAK
16008       GO=GO*OFAK
16009       DS2=(GO-GU)/99.D0
16010       AM11=AM1*AM1
16011       AM22=AM2*AM2
16012       AM33=AM3*AM3
16013       UMO2=UMO*UMO
16014       RHO2=0.D0
16015       S22=GU
16016       DO 124 I=1,100
16017          S21=S22
16018          S22=GU+(I-1.D0)*DS2
16019          RHO1=RHO2
16020          RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
16021      *                                             (S22+EPS)
16022          IF(RHO2.LT.RHO1) GO TO 125
16023   124 CONTINUE
16024   125 S2SUP=(S22-S21)*.5D0+S21
16025       SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
16026      *                                           (S2SUP+EPS)
16027       SUPRHO=SUPRHO*1.05D0
16028       XO=S21-DS2
16029       IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
16030       IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
16031       XX(1)=XO
16032       XX(3)=S22
16033       X1=(XO+S22)*0.5D0
16034       XX(2)=X1
16035       F(3)=RHO2
16036       F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
16037       F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
16038       DO 126 I=1,16
16039          X4=(XX(1)+XX(2))*0.5D0
16040          X5=(XX(2)+XX(3))*0.5D0
16041          F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
16042      *                                               (X4+EPS)
16043          F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
16044      *                                               (X5+EPS)
16045          XX(4)=X4
16046          XX(5)=X5
16047          DO 128 II=1,5
16048             IA=II
16049             DO 128 III=IA,5
16050                IF (F (II).GE.F (III)) GO TO 128
16051                FH=F(II)
16052                F(II)=F(III)
16053                F(III)=FH
16054                FH=XX(II)
16055                XX(II)=XX(III)
16056                XX(III)=FH
16057 128      CONTINUE
16058          SUPRHO=F(1)
16059          S2SUP=XX(1)
16060          DO 129 II=1,3
16061             IA=II
16062             DO 129 III=IA,3
16063                IF (XX(II).GE.XX(III)) GO TO 129
16064                FH=F(II)
16065                F(II)=F(III)
16066                F(III)=FH
16067                FH=XX(II)
16068                XX(II)=XX(III)
16069                XX(III)=FH
16070 129      CONTINUE
16071 126   CONTINUE
16072       AM23=(AM2+AM3)**2
16073       ITH=0
16074       REDU=2.D0
16075     1 CONTINUE
16076       ITH=ITH+1
16077       IF (ITH.GT.200) REDU=-9.D0
16078       IF (ITH.GT.200) GO TO 400
16079       C=DT_RNDM(REDU)
16080 *     S2=AM23+C*((UMO-AM1)**2-AM23)
16081       S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
16082       Y=DT_RNDM(S2)
16083       Y=Y*SUPRHO
16084       RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
16085       IF(Y.GT.RHO) GO TO 1
16086 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
16087       S1=DT_RNDM(S2)
16088       S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
16089      &RHO*.5D0
16090       S3=UMO2+AM11+AM22+AM33-S1-S2
16091       ECM1=(UMO2+AM11-S2)/UMOO
16092       ECM2=(UMO2+AM22-S3)/UMOO
16093       ECM3=(UMO2+AM33-S1)/UMOO
16094       PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
16095       PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
16096       PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
16097       CALL DT_DSFECF(SFE,CFE)
16098 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
16099 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
16100       PCM12 = PCM1 * PCM2
16101       IF ( PCM12 .LT. ANGLSQ ) GO TO 200
16102       COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
16103       GO TO 300
16104  200  CONTINUE
16105          UW=DT_RNDM(S1)
16106          COSTH=(UW-0.5D+00)*2.D+00
16107  300  CONTINUE
16108 *     IF(ABS(COSTH).GT.0.9999999999999999D0)
16109 *    &COSTH=SIGN(0.9999999999999999D0,COSTH)
16110       IF(ABS(COSTH).GT.ONEONE)
16111      &COSTH=SIGN(ONEONE,COSTH)
16112       IF (REDU.LT.1.D+00) RETURN
16113       COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
16114 *     IF(ABS(COSTH2).GT.0.9999999999999999D0)
16115 *    &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
16116       IF(ABS(COSTH2).GT.ONEONE)
16117      &COSTH2=SIGN(ONEONE,COSTH2)
16118       SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
16119       SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
16120       SINTH1=COSTH2*SINTH-COSTH*SINTH2
16121       COSTH1=COSTH*COSTH2+SINTH2*SINTH
16122 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
16123 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
16124 C***THE DIRECTION OF PARTICLE 3
16125 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
16126       CX11=-COSTH1
16127       CY11=SINTH1*CFE
16128       CZ11=SINTH1*SFE
16129       CX22=-COSTH2
16130       CY22=-SINTH2*CFE
16131       CZ22=-SINTH2*SFE
16132       CALL DT_DSFECF(SIF3,COF3)
16133       COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
16134       SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
16135     2 FORMAT(5F20.15)
16136       COD1=CX11*COD3+CZ11*SID3
16137       CHLP=(ONEONE-COD1)*(ONEONE+COD1)
16138       IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
16139      &CX11,CZ11
16140       SID1=SQRT(CHLP)
16141       COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
16142       SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
16143       COD2=CX22*COD3+CZ22*SID3
16144       SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
16145       COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
16146       SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
16147  400  CONTINUE
16148 * === Energy conservation check: === *
16149       EOCHCK = UMO - ECM1 - ECM2 - ECM3
16150 *     SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
16151 *     SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
16152 *     SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
16153       PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
16154       PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
16155      &       + PCM3 * COF3 * SID3
16156       PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
16157      &       + PCM3 * SIF3 * SID3
16158       EOCMPR = 1.D-12 * UMO
16159       IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
16160      &     .GT. EOCMPR ) THEN
16161 **sr 5.5.95 output-unit changed
16162          IF (IOULEV(1).GT.0) THEN
16163             WRITE(LOUT,*)
16164      &      ' *** Threpd: energy/momentum conservation failure! ***',
16165      &      EOCHCK,PXCHCK,PYCHCK,PZCHCK
16166             WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
16167          ENDIF
16168 **
16169       END IF
16170       RETURN
16171       END
16172
16173 *$ CREATE DT_DBKLAS.FOR
16174 *COPY DT_DBKLAS
16175 *
16176 *===dbklas=============================================================*
16177 *
16178       SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
16179
16180       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16181       SAVE
16182
16183       PARAMETER ( LINP = 10 ,
16184      &            LOUT = 6 ,
16185      &            LDAT = 9 )
16186
16187 * quark-content to particle index conversion (DTUNUC 1.x)
16188       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16189      &                IA08(6,21),IA10(6,21)
16190
16191       IF (I) 20,20,10
16192 * baryons
16193    10 CONTINUE
16194       CALL DT_INDEXD(J,K,IND)
16195       I8  = IB08(I,IND)
16196       I10 = IB10(I,IND)
16197       IF (I8.LE.0) I8 = I10
16198       RETURN
16199 * antibaryons
16200    20 CONTINUE
16201       II = IABS(I)
16202       JJ = IABS(J)
16203       KK = IABS(K)
16204       CALL DT_INDEXD(JJ,KK,IND)
16205       I8  = IA08(II,IND)
16206       I10 = IA10(II,IND)
16207       IF (I8.LE.0) I8 = I10
16208
16209       RETURN
16210       END
16211
16212 *$ CREATE DT_INDEXD.FOR
16213 *COPY DT_INDEXD
16214 *
16215 *===indexd=============================================================*
16216 *
16217       SUBROUTINE DT_INDEXD(KA,KB,IND)
16218
16219       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16220       SAVE
16221
16222       PARAMETER ( LINP = 10 ,
16223      &            LOUT = 6 ,
16224      &            LDAT = 9 )
16225
16226       KP = KA*KB
16227       KS = KA+KB
16228       IF (KP.EQ.1) IND=1
16229       IF (KP.EQ.2) IND=2
16230       IF (KP.EQ.3) IND=3
16231       IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
16232       IF (KP.EQ.5) IND=5
16233       IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
16234       IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
16235       IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
16236       IF (KP.EQ.8)  IND=9
16237       IF (KP.EQ.10) IND=10
16238       IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
16239       IF (KP.EQ.9)  IND=12
16240       IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
16241       IF (KP.EQ.15) IND=14
16242       IF (KP.EQ.18) IND=15
16243       IF (KP.EQ.16) IND=16
16244       IF (KP.EQ.20) IND=17
16245       IF (KP.EQ.24) IND=18
16246       IF (KP.EQ.25) IND=19
16247       IF (KP.EQ.30) IND=20
16248       IF (KP.EQ.36) IND=21
16249
16250       RETURN
16251       END
16252
16253 *$ CREATE DT_DCHANT.FOR
16254 *COPY DT_DCHANT
16255 *
16256 *===dchant=============================================================*
16257 *
16258       SUBROUTINE DT_DCHANT
16259
16260       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16261       SAVE
16262
16263       PARAMETER ( LINP = 10 ,
16264      &            LOUT = 6 ,
16265      &            LDAT = 9 )
16266
16267       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16268
16269 * HADRIN: decay channel information
16270       PARAMETER (IDMAX9=602)
16271       CHARACTER*8 ZKNAME
16272       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
16273
16274 * particle properties (BAMJET index convention)
16275       CHARACTER*8  ANAME
16276       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16277      &                IICH(210),IIBAR(210),K1(210),K2(210)
16278
16279       DIMENSION HWT(IDMAX9)
16280
16281 * change of weights wt from absolut values into the sum of wt of a dec.
16282       DO 10 J=1,IDMAX9
16283          HWT(J) = ZERO
16284    10 CONTINUE
16285 C     DO 999 KKK=1,210
16286 C        WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
16287 C    &      ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
16288 C    &      K1(KKK),K2(KKK)
16289 C 999 CONTINUE
16290 C     STOP
16291       DO 30 I=1,210
16292          IK1 = K1(I)
16293          IK2 = K2(I)
16294          HV  = ZERO
16295          DO 20 J=IK1,IK2
16296             HV     = HV+WT(J)
16297             HWT(J) = HV
16298 **sr 13.1.95
16299             IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
16300  1000       FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
16301    20    CONTINUE
16302    30 CONTINUE
16303       DO 40 J=1,IDMAX9
16304          WT(J) = HWT(J)
16305    40 CONTINUE
16306
16307       RETURN
16308       END
16309
16310 *$ CREATE DT_DDATAR.FOR
16311 *COPY DT_DDATAR
16312 *
16313 *===ddatar=============================================================*
16314 *
16315       SUBROUTINE DT_DDATAR
16316
16317       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16318       SAVE
16319
16320       PARAMETER ( LINP = 10 ,
16321      &            LOUT = 6 ,
16322      &            LDAT = 9 )
16323
16324       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16325
16326 * quark-content to particle index conversion (DTUNUC 1.x)
16327       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16328      &                IA08(6,21),IA10(6,21)
16329
16330       DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
16331
16332       DATA IV/ 33, 34, 38,123,  0,  0, 32, 33, 39,124,
16333      &          0,  0, 36, 37, 96,127,  0,  0,126,125,
16334      &        128,129,14*0/
16335       DATA IP/ 23, 14, 16,116,  0,  0, 13, 23, 25,117,
16336      &          0,  0, 15, 24, 31,120,  0,  0,119,118,
16337      &        121,122,14*0/
16338       DATA IB/  0,  1, 21,140,  0,  0,  8, 22,137,  0,
16339      &          0, 97,138,  0,  0,146,  0,  0,  0,  0,
16340      &          0,  1,  8, 22,137,  0,  0,  0, 20,142,
16341      &          0,  0, 98,139,  0,  0,147,  0,  0,  0,
16342      &          0,  0, 21, 22, 97,138,  0,  0, 20, 98,
16343      &        139,  0,  0,  0,145,  0,  0,148,  0,  0,
16344      &          0,  0,  0,140,137,138,146,  0,  0,142,
16345      &        139,147,  0,  0,145,148,           50*0/
16346       DATA IBB/53, 54,104,161,  0,  0, 55,105,162,  0,
16347      &          0,107,164,  0,  0,167,  0,  0,  0,  0,
16348      &          0, 54, 55,105,162,  0,  0, 56,106,163,
16349      &          0,  0,108,165,  0,  0,168,  0,  0,  0,
16350      &          0,  0,104,105,107,164,  0,  0,106,108,
16351      &        165,  0,  0,109,166,  0,  0,169,  0,  0,
16352      &          0,  0,  0,161,162,164,167,  0,  0,163,
16353      &        165,168,  0,  0,166,169,  0,  0,170,47*0/
16354       DATA IA/  0,  2, 99,152,  0,  0,  9,100,149,  0,
16355      &          0,102,150,  0,  0,158,  0,  0,  0,  0,
16356      &          0,  2,  9,100,149,  0,  0,  0,101,154,
16357      &          0,  0,103,151,  0,  0,159,  0,  0,  0,
16358      &          0,  0, 99,100,102,150,  0,  0,101,103,
16359      &        151,  0,  0,  0,157,  0,  0,160,  0,  0,
16360      &          0,  0,  0,152,149,150,158,  0,  0,154,
16361      &        151,159,  0,  0,157,160,           50*0/
16362       DATA IAA/67, 68,110,171,  0,  0, 69,111,172,  0,
16363      &          0,113,174,  0,  0,177,  0,  0,  0,  0,
16364      &          0, 68, 69,111,172,  0,  0, 70,112,173,
16365      &          0,  0,114,175,  0,  0,178,  0,  0,  0,
16366      &          0,  0,110,111,113,174,  0,  0,112,114,
16367      &        175,  0,  0,115,176,  0,  0,179,  0,  0,
16368      &          0,  0,  0,171,172,174,177,  0,  0,173,
16369      &        175,178,  0,  0,176,179,  0,  0,180,47*0/
16370
16371       L=0
16372       DO 2 I=1,6
16373          DO 1 J=1,6
16374             L = L+1
16375             IMPS(I,J) = IP(L)
16376             IMVE(I,J) = IV(L)
16377     1    CONTINUE
16378     2 CONTINUE
16379       L=0
16380       DO 4 I=1,6
16381          DO 3 J=1,21
16382             L = L+1
16383             IB08(I,J) = IB(L)
16384             IB10(I,J) = IBB(L)
16385             IA08(I,J) = IA(L)
16386             IA10(I,J) = IAA(L)
16387     3    CONTINUE
16388     4 CONTINUE
16389 C     A1  = 0.88D0
16390 C     B1  = 3.0D0
16391 C     B2  = 3.0D0
16392 C     B3  = 8.0D0
16393 C     LT  = 0
16394 C     LB  = 0
16395 C     BET = 12.0D0
16396 C     AS  = 0.25D0
16397 C     B8  = 0.33D0
16398 C     AME = 0.95D0
16399 C     DIQ = 0.375D0
16400 C     ISU = 4
16401
16402       RETURN
16403       END
16404
16405 *$ CREATE DT_INITJS.FOR
16406 *COPY DT_INITJS
16407 *
16408 *===initjs=============================================================*
16409 *
16410       SUBROUTINE DT_INITJS(MODE)
16411
16412 ************************************************************************
16413 * Initialize JETSET paramters.                                         *
16414 *           MODE = 0 default settings                                  *
16415 *                = 1 PHOJET settings                                   *
16416 *                = 2 DTUNUC settings                                   *
16417 * This version dated 16.02.96 is written by S. Roesler                 *
16418 *                                                                      *
16419 * Last change 27.12.2006 by S. Roesler.                                *
16420 ************************************************************************
16421
16422       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16423       SAVE
16424
16425       PARAMETER ( LINP = 10 ,
16426      &            LOUT = 6 ,
16427      &            LDAT = 9 )
16428
16429       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16430
16431       LOGICAL LFIRST,LFIRDT,LFIRPH
16432
16433 *      INCLUDE '(DIMPAR)'
16434 *     DIMPAR taken from FLUKA
16435       PARAMETER ( MXXRGN =20000 )
16436       PARAMETER ( MXXMDF =  710 )
16437       PARAMETER ( MXXMDE =  702 )
16438       PARAMETER ( MFSTCK =40000 )
16439       PARAMETER ( MESTCK =  100 )
16440       PARAMETER ( MOSTCK = 2000 )
16441       PARAMETER ( MXPRSN =  100 )
16442       PARAMETER ( MXPDPM =  800 )
16443       PARAMETER ( MXPSCS =30000 )
16444       PARAMETER ( MXGLWN =  300 )
16445       PARAMETER ( MXOUTU =   50 )
16446       PARAMETER ( NALLWP =   64 )
16447       PARAMETER ( NELEMX =   80 )
16448       PARAMETER ( MPDPDX =   18 )
16449       PARAMETER ( MXHTTR =  260 )
16450       PARAMETER ( MXSEAX =   20 )
16451       PARAMETER ( MXHTNC = MXSEAX + 1 )
16452       PARAMETER ( ICOMAX = 2400 )
16453       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
16454       PARAMETER ( NSTBIS =  304 )
16455       PARAMETER ( NQSTIS =   46 )
16456       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
16457       PARAMETER ( MXPABL =  120 )
16458       PARAMETER ( IDMAXP =  450 )
16459       PARAMETER ( IDMXDC = 2000 )
16460       PARAMETER ( MXMCIN =  410 )
16461       PARAMETER ( IHYPMX =    4 )
16462       PARAMETER ( MKBMX1 =   11 )
16463       PARAMETER ( MKBMX2 =   11 )
16464       PARAMETER ( MXIRRD = 2500 )
16465       PARAMETER ( MXTRDC = 1500 )
16466       PARAMETER ( NKTL   =   17 )
16467       PARAMETER ( NBLNMX = 40000000 )
16468
16469 *      INCLUDE '(PART)'
16470 *     PART taken from FLUKA
16471       PARAMETER ( KPETA0 =  31 )
16472       PARAMETER ( KPRHOP =  32 )
16473       PARAMETER ( KPRHO0 =  33 )
16474       PARAMETER ( KPRHOM =  34 )
16475       PARAMETER ( KPOME0 =  35 )
16476       PARAMETER ( KPPHI0 =  96 )
16477       PARAMETER ( KPDEPP =  53 )
16478       PARAMETER ( KPDELP =  54 )
16479       PARAMETER ( KPDEL0 =  55 )
16480       PARAMETER ( KPDELM =  56 )
16481       PARAMETER ( KPN14P =  91 )
16482       PARAMETER ( KPN140 =  92 )
16483 *  Low mass diffraction partners:
16484       PARAMETER ( KDETA0 =   0 )
16485       PARAMETER ( KDRHOP =   0 )
16486       PARAMETER ( KDRHO0 = 210 )
16487       PARAMETER ( KDRHOM =   0 )
16488       PARAMETER ( KDOME0 = 210 )
16489       PARAMETER ( KDPHI0 = 210 )
16490       PARAMETER ( KDDEPP =   0 )
16491       PARAMETER ( KDDELP =   0 )
16492       PARAMETER ( KDDEL0 =   0 )
16493       PARAMETER ( KDDELM =   0 )
16494       PARAMETER ( KDN14P =   0 )
16495       PARAMETER ( KDN140 =   0 )
16496 *
16497       CHARACTER*8  ANAME
16498       COMMON / PART /  AM     (-6:IDMAXP), GA     (-6:IDMAXP),
16499      &                 TAU    (-6:IDMAXP), AMDISC (-6:IDMAXP),
16500      &                 ZMNABS (-6:IDMAXP), ATNMNA (-6:IDMAXP),
16501      &                 ATXN14,     ATMN14, RNRN14    (-10:10),
16502      &                 ICH    (-6:IDMAXP), IBAR   (-6:IDMAXP),
16503      &                 ISOSYM (-6:IDMAXP), ICHCON (-6:IDMAXP),
16504      &                 K1     (-6:IDMAXP), K2     (-6:IDMAXP),
16505      &                 KPTOIP (-6:IDMAXP), IPTOKP (-6:NALLWP),
16506      &                 KPTOIA (-6:IDMAXP), IATOKP (-6:MXPABL),
16507      &                 IDCFLG (-6:NALLWP), IPTYPE (-6:NALLWP)
16508
16509       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16510       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16511       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16512
16513 * flags for particle decays
16514       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
16515      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
16516      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
16517
16518 * flags for input different options
16519       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16520       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16521      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16522
16523       INTEGER PYCOMP
16524
16525       DIMENSION IDXSTA(40)
16526       DATA IDXSTA
16527 *          K0s   pi0  lam   alam  sig+  asig+ sig-  asig- tet0  atet0
16528      &  /  310,  111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
16529 *          tet- atet-  om-  aom-   D+    D-    D0    aD0   Ds+   aDs+
16530      &    3312,-3312, 3334,-3334,  411, -411,  421, -421,  431, -431,
16531 *          etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
16532      &     441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
16533 *         Ksic0 aKsic+aKsic0 sig0 asig0
16534      &    4132,-4232,-4132, 3212,-3212, 5*0/
16535
16536       DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
16537
16538       IF (LFIRST) THEN
16539 * save default settings
16540          PDEF1  = PARJ(1)
16541          PDEF2  = PARJ(2)
16542          PDEF3  = PARJ(3)
16543          PDEF5  = PARJ(5)
16544          PDEF6  = PARJ(6)
16545          PDEF7  = PARJ(7)
16546          PDEF18 = PARJ(18)
16547          PDEF19 = PARJ(19)
16548          PDEF21 = PARJ(21)
16549          PDEF42 = PARJ(42)
16550          MDEF12 = MSTJ(12)
16551 * LUJETS / PYJETS array-dimensions
16552
16553          MSTU(4) = 4000
16554
16555 * increase maximum number of JETSET-error prints
16556          MSTU(22) = 50000
16557 * prevent particles decaying
16558          DO 1 I=1,35
16559             IF (I.LT.34) THEN
16560
16561                KC = PYCOMP(IDXSTA(I))
16562
16563                IF (KC.GT.0) THEN
16564                   IF (I.EQ.2) THEN
16565 *  pi0 decay
16566 C                    MDCY(KC,1) = 1
16567                      MDCY(KC,1) = 0
16568 **cr mode
16569 C                 ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
16570 C   &                    (I.EQ.8).OR.(I.EQ.10)) THEN
16571 C                 ELSEIF (I.EQ.4) THEN
16572 C                    MDCY(KC,1) = 1
16573 **
16574                   ELSE
16575                      MDCY(KC,1) = 0
16576                   ENDIF
16577                ENDIF
16578             ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
16579
16580                KC = PYCOMP(IDXSTA(I))
16581
16582                IF (KC.GT.0) THEN
16583                   MDCY(KC,1) = 0
16584                ENDIF
16585             ENDIF
16586     1    CONTINUE
16587 *
16588
16589 * as Fluka event-generator: allow only paprop particles to be stable
16590 * and let all other particles decay (i.e. those with strong decays)
16591          IF (ITRSPT.EQ.1) THEN
16592             DO 5 I=1,IDMAXP
16593                IF (KPTOIP(I).NE.0) THEN
16594                   IDPDG = MPDGHA(I)
16595
16596                   KC    = PYCOMP(IDPDG)
16597
16598                   IF (KC.GT.0) THEN
16599                      IF (MDCY(KC,1).EQ.1) THEN
16600                         WRITE(LOUT,*)
16601      &                     ' DT_INITJS: Decay flag for FLUKA-',
16602      &                     'transport : particle should not ',
16603      &                     'decay : ',IDPDG,'  ',ANAME(I)
16604                         MDCY(KC,1) = 0
16605                      ENDIF
16606                   ENDIF
16607                ENDIF
16608     5       CONTINUE
16609             DO 6 KC=1,500
16610                IDPDG = KCHG(KC,4)
16611                KP    = MCIHAD(IDPDG)
16612                IF (KP.GT.0) THEN
16613                   IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND.
16614      &                (ANAME(KP).NE.'BLANK   ').AND.
16615      &                (ANAME(KP).NE.'RNDFLV  ')) THEN
16616                      WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
16617      &                             'transport: particle should decay ',
16618      &                             ': ',IDPDG,' ',ANAME(KP)
16619                      MDCY(KC,1) = 1
16620                   ENDIF
16621                ENDIF
16622     6       CONTINUE
16623          ENDIF
16624
16625 *
16626 * popcorn:
16627          IF (PDB.LE.ZERO) THEN
16628 *   no popcorn-mechanism
16629             MSTJ(12) = 1
16630          ELSE
16631             MSTJ(12) = 3
16632             PARJ(5)  = PDB
16633          ENDIF
16634 * set JETSET-parameter requested by input cards
16635          IF (NMSTU.GT.0) THEN
16636             DO 2 I=1,NMSTU
16637                MSTU(IMSTU(I)) = MSTUX(I)
16638     2       CONTINUE
16639          ENDIF
16640          IF (NMSTJ.GT.0) THEN
16641             DO 3 I=1,NMSTJ
16642                MSTJ(IMSTJ(I)) = MSTJX(I)
16643     3       CONTINUE
16644          ENDIF
16645          IF (NPARU.GT.0) THEN
16646             DO 4 I=1,NPARU
16647                PARU(IPARU(I)) = PARUX(I)
16648     4       CONTINUE
16649          ENDIF
16650          LFIRST = .FALSE.
16651       ENDIF
16652 *
16653 * PARJ(1)  suppression of qq-aqaq pair prod. compared to
16654 *          q-aq pair prod.                      (default: 0.1)
16655 * PARJ(2)  strangeness suppression               (default: 0.3)
16656 * PARJ(3)  extra suppression of strange diquarks (default: 0.4)
16657 * PARJ(6)  extra suppression of sas-pair shared by B and
16658 *          aB in BMaB                           (default: 0.5)
16659 * PARJ(7)  extra suppression of strange meson M in BMaB
16660 *          configuration                        (default: 0.5)
16661 * PARJ(18) spin 3/2 baryon suppression           (default: 1.0)
16662 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
16663 *          momentum distrib. for prim. hadrons  (default: 0.35)
16664 * PARJ(42) b-parameter for symmetric Lund-fragmentation
16665 *          function                             (default: 0.9 GeV^-2)
16666 *
16667 * PHOJET settings
16668       IF (MODE.EQ.1) THEN
16669 *   JETSET default
16670 C        PARJ(1)  = PDEF1
16671 C        PARJ(2)  = PDEF2
16672 C        PARJ(3)  = PDEF3
16673 C        PARJ(6)  = PDEF6
16674 C        PARJ(7)  = PDEF7
16675 C        PARJ(18) = PDEF18
16676 C        PARJ(21) = PDEF21
16677 C        PARJ(42) = PDEF42
16678 **sr 18.11.98 parameter tuning
16679 C        PARJ(1)  = 0.092D0
16680 C        PARJ(2)  = 0.25D0
16681 C        PARJ(3)  = 0.45D0
16682 C        PARJ(19) = 0.3D0
16683 C        PARJ(21) = 0.45D0
16684 C        PARJ(42) = 1.0D0
16685 **sr 28.04.99 parameter tuning (May 99 minor modifications)
16686          PARJ(1)  = 0.085D0
16687          PARJ(2)  = 0.26D0
16688          PARJ(3)  = 0.8D0
16689          PARJ(11) = 0.38D0
16690          PARJ(18) = 0.3D0
16691          PARJ(19) = 0.4D0
16692          PARJ(21) = 0.36D0
16693          PARJ(41) = 0.3D0
16694          PARJ(42) = 0.86D0
16695          IF (NPARJ.GT.0) THEN
16696             DO 10 I=1,NPARJ
16697                IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
16698    10       CONTINUE
16699          ENDIF
16700          IF (LFIRPH) THEN
16701             WRITE(LOUT,'(1X,A)')
16702      &         'DT_INITJS: JETSET-parameter for PHOJET'
16703             CALL DT_JSPARA(0)
16704             LFIRPH = .FALSE.
16705          ENDIF
16706 * DTUNUC settings
16707       ELSEIF (MODE.EQ.2) THEN
16708          IF (IFRAG(2).EQ.1) THEN
16709 **sr parameters before 9.3.96
16710 C           PARJ(2)  = 0.27D0
16711 C           PARJ(3)  = 0.6D0
16712 C           PARJ(6)  = 0.75D0
16713 C           PARJ(7)  = 0.75D0
16714 C           PARJ(21) = 0.55D0
16715 C           PARJ(42) = 1.3D0
16716 **sr 18.11.98 parameter tuning
16717 C           PARJ(1)  = 0.05D0
16718 C           PARJ(2)  = 0.27D0
16719 C           PARJ(3)  = 0.4D0
16720 C           PARJ(19) = 0.2D0
16721 C           PARJ(21) = 0.45D0
16722 C           PARJ(42) = 1.0D0
16723 **sr 28.04.99 parameter tuning
16724             PARJ(1)  = 0.11D0
16725             PARJ(2)  = 0.36D0
16726             PARJ(3)  = 0.8D0
16727             PARJ(19) = 0.2D0
16728             PARJ(21) = 0.3D0
16729             PARJ(41) = 0.3D0
16730             PARJ(42) = 0.58D0
16731             IF (NPARJ.GT.0) THEN
16732                DO 20 I=1,NPARJ
16733                   IF (IPARJ(I).LT.0) THEN
16734                      IDX = ABS(IPARJ(I))
16735                      PARJ(IDX) = PARJX(I)
16736                   ENDIF
16737    20          CONTINUE
16738             ENDIF
16739             IF (LFIRDT) THEN
16740                WRITE(LOUT,'(1X,A)')
16741      &           'DT_INITJS: JETSET-parameter for DTUNUC'
16742                CALL DT_JSPARA(0)
16743                LFIRDT = .FALSE.
16744             ENDIF
16745          ELSEIF (IFRAG(2).EQ.2) THEN
16746             PARJ(1)  = 0.11D0
16747             PARJ(2)  = 0.27D0
16748             PARJ(3)  = 0.3D0
16749             PARJ(6)  = 0.35D0
16750             PARJ(7)  = 0.45D0
16751             PARJ(18) = 0.66D0
16752 C           PARJ(21) = 0.55D0
16753 C           PARJ(42) = 1.0D0
16754             PARJ(21) = 0.60D0
16755             PARJ(42) = 1.3D0
16756          ELSE
16757             PARJ(1)  = PDEF1
16758             PARJ(2)  = PDEF2
16759             PARJ(3)  = PDEF3
16760             PARJ(6)  = PDEF6
16761             PARJ(7)  = PDEF7
16762             PARJ(18) = PDEF18
16763             PARJ(21) = PDEF21
16764             PARJ(42) = PDEF42
16765          ENDIF
16766       ELSE
16767          PARJ(1)  = PDEF1
16768          PARJ(2)  = PDEF2
16769          PARJ(3)  = PDEF3
16770          PARJ(5)  = PDEF5
16771          PARJ(6)  = PDEF6
16772          PARJ(7)  = PDEF7
16773          PARJ(18) = PDEF18
16774          PARJ(19) = PDEF19
16775          PARJ(21) = PDEF21
16776          PARJ(42) = PDEF42
16777          MSTJ(12) = MDEF12
16778       ENDIF
16779
16780       RETURN
16781       END
16782
16783 *$ CREATE DT_JSPARA.FOR
16784 *COPY DT_JSPARA
16785 *
16786 *===jspara=============================================================*
16787 *
16788       SUBROUTINE DT_JSPARA(MODE)
16789
16790       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16791       SAVE
16792
16793       PARAMETER ( LINP = 10 ,
16794      &            LOUT = 6 ,
16795      &            LDAT = 9 )
16796
16797       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
16798      &           ONE=1.0D0,ZERO=0.0D0)
16799
16800       LOGICAL LFIRST
16801
16802       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16803
16804       DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
16805
16806       DATA LFIRST /.TRUE./
16807
16808 * save the default JETSET-parameter on the first call
16809       IF (LFIRST) THEN
16810          DO 1 I=1,200
16811             ISTU(I) = MSTU(I)
16812             QARU(I) = PARU(I)
16813             ISTJ(I) = MSTJ(I)
16814             QARJ(I) = PARJ(I)
16815     1    CONTINUE
16816          LFIRST = .FALSE.
16817       ENDIF
16818
16819       WRITE(LOUT,1000)
16820  1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16821
16822 * compare the default JETSET-parameter with the present values
16823       DO 2 I=1,200
16824          IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16825             WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16826 C           ISTU(I) = MSTU(I)
16827          ENDIF
16828          DIFF = ABS(PARU(I)-QARU(I))
16829          IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16830             WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16831 C           QARU(I) = PARU(I)
16832          ENDIF
16833          IF (MSTJ(I).NE.ISTJ(I)) THEN
16834             WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16835 C           ISTJ(I) = MSTJ(I)
16836          ENDIF
16837          DIFF = ABS(PARJ(I)-QARJ(I))
16838          IF (DIFF.GE.1.0D-5) THEN
16839             WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16840 C           QARJ(I) = PARJ(I)
16841          ENDIF
16842     2 CONTINUE
16843  1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16844  1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16845
16846       RETURN
16847       END
16848 *$ CREATE DT_FOZOCA.FOR
16849 *COPY DT_FOZOCA
16850 *
16851 *===fozoca=============================================================*
16852 *
16853       SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16854
16855 ************************************************************************
16856 * This subroutine treats the complete FOrmation ZOne supressed intra-  *
16857 * nuclear CAscade.                                                     *
16858 *               LFZC = .true.  cascade has been treated                *
16859 *                    = .false. cascade skipped                         *
16860 * This is a completely revised version of the original FOZOKL.         *
16861 * This version dated 18.11.95 is written by S. Roesler                 *
16862 ************************************************************************
16863
16864       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16865       SAVE
16866
16867       PARAMETER ( LINP = 10 ,
16868      &            LOUT = 6 ,
16869      &            LDAT = 9 )
16870
16871       PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16872       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16873
16874       LOGICAL LSTART,LCAS,LFZC
16875
16876 * event history
16877
16878       PARAMETER (NMXHKK=200000)
16879
16880       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16881      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16882      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16883
16884 * extended event history
16885       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16886      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16887      &                IHIST(2,NMXHKK)
16888
16889 * rejection counter
16890       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16891      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16892      &                IREXCI(3),IRDIFF(2),IRINC
16893
16894 * properties of interacting particles
16895       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16896
16897 * Glauber formalism: collision properties
16898       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16899      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16900
16901 * flags for input different options
16902       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16903       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16904      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16905
16906 * final state after intranuclear cascade step
16907       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16908
16909 * parameter for intranuclear cascade
16910       LOGICAL LPAULI
16911       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16912
16913       DIMENSION NCWOUN(2)
16914
16915       DATA LSTART /.TRUE./
16916
16917       LFZC = .TRUE.
16918       IREJ = 0
16919
16920 * skip cascade if hadron-hadron interaction or if supressed by user
16921       IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16922 * skip cascade if not all possible chains systems are hadronized
16923       DO 1 I=1,8
16924          IF (.NOT.LHADRO(I)) GOTO 9999
16925     1 CONTINUE
16926
16927       IF (LSTART) THEN
16928          WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16929  1000    FORMAT(/,1X,'FOZOCA:  intranuclear cascade treated for a ',
16930      &          'maximum of',I4,' generations',/,10X,'formation time ',
16931      &          'parameter:',F5.1,'  fm/c',9X,'modus:',I2)
16932          IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16933          IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16934  1001    FORMAT(10X,'p_t dependent formation zone',/)
16935  1002    FORMAT(10X,'constant formation zone',/)
16936          LSTART = .FALSE.
16937       ENDIF
16938
16939 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16940 * which may interact with final state particles are stored in a seperate
16941 * array - here all proj./target nucleon-indices (just for simplicity)
16942       NOINC = 0
16943       DO 9 I=1,NPOINT(1)-1
16944          NOINC = NOINC+1
16945          IDXINC(NOINC) = I
16946     9 CONTINUE
16947
16948 * initialize Pauli-principle treatment (find wounded nucleons)
16949       NWOUND(1) = 0
16950       NWOUND(2) = 0
16951       NCWOUN(1) = 0
16952       NCWOUN(2) = 0
16953       DO 2 J=1,NPOINT(1)
16954          DO 3 I=1,2
16955             IF (ISTHKK(J).EQ.10+I) THEN
16956                NWOUND(I) = NWOUND(I)+1
16957                EWOUND(I,NWOUND(I)) = PHKK(4,J)
16958                IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16959             ENDIF
16960     3    CONTINUE
16961     2 CONTINUE
16962
16963 * modify nuclear potential for wounded nucleons
16964       IPRCL  = IP -NWOUND(1)
16965       IPZRCL = IPZ-NCWOUN(1)
16966       ITRCL  = IT -NWOUND(2)
16967       ITZRCL = ITZ-NCWOUN(2)
16968       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16969
16970       NSTART = NPOINT(4)
16971       NEND   = NHKK
16972
16973     7 CONTINUE
16974       DO 8 I=NSTART,NEND
16975
16976          IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16977 * select nucleus the cascade starts first (proj. - 1, target - -1)
16978             NCAS   = 1
16979 *   projectile/target with probab. 1/2
16980             IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16981                IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16982 *   in the nucleus with highest mass
16983             ELSEIF (INCMOD.EQ.2) THEN
16984                IF (IP.GT.IT) THEN
16985                   NCAS = -NCAS
16986                ELSEIF (IP.EQ.IT) THEN
16987                   IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16988                ENDIF
16989 * the nucleus the cascade starts first is requested to be the one
16990 * moving in the direction of the secondary
16991             ELSEIF (INCMOD.EQ.3) THEN
16992                NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
16993             ENDIF
16994 * check that the selected "nucleus" is not a hadron
16995             IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
16996      &          ((NCAS.EQ.-1).AND.(IT.LE.1)))    NCAS = -NCAS
16997
16998 * treat intranuclear cascade in the nucleus selected first
16999             LCAS = .FALSE.
17000             CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17001             IF (IREJ1.NE.0) GOTO 9998
17002 * treat intranuclear cascade in the other nucleus if this isn't a had.
17003             NCAS = -NCAS
17004             IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
17005      &          ((NCAS.EQ.-1).AND.(IT.GT.1)))    THEN
17006                IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17007                IF (IREJ1.NE.0) GOTO 9998
17008             ENDIF
17009
17010          ENDIF
17011
17012     8 CONTINUE
17013       NSTART = NEND+1
17014       NEND   = NHKK
17015       IF (NSTART.LE.NEND) GOTO 7
17016
17017       RETURN
17018
17019  9998 CONTINUE
17020 * reject this event
17021       IRINC = IRINC+1
17022       IREJ = 1
17023
17024  9999 CONTINUE
17025 * intranucl. cascade not treated because of interaction properties or
17026 * it is supressed by user or it was rejected or...
17027       LFZC = .FALSE.
17028 * reset flag characterizing direction of motion in n-n-cms
17029 **sr14-11-95
17030 C     DO 9990 I=NPOINT(5),NHKK
17031 C        IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
17032 C9990 CONTINUE
17033
17034       RETURN
17035       END
17036
17037 *$ CREATE DT_INUCAS.FOR
17038 *COPY DT_INUCAS
17039 *
17040 *===inucas=============================================================*
17041 *
17042       SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
17043
17044 ************************************************************************
17045 * Formation zone supressed IntraNUclear CAScade for one final state    *
17046 * particle.                                                            *
17047 *           IT, IP    mass numbers of target, projectile nuclei        *
17048 *           IDXCAS    index of final state particle in DTEVT1          *
17049 *           NCAS =  1 intranuclear cascade in projectile               *
17050 *                = -1 intranuclear cascade in target                   *
17051 * This version dated 18.11.95 is written by S. Roesler                 *
17052 ************************************************************************
17053
17054       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17055       SAVE
17056
17057       PARAMETER ( LINP = 10 ,
17058      &            LOUT = 6 ,
17059      &            LDAT = 9 )
17060
17061       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
17062      &           OHALF=0.5D0,ONE=1.0D0)
17063       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
17064       PARAMETER (TWOPI=6.283185307179586454D+00)
17065       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
17066
17067       LOGICAL LABSOR,LCAS
17068
17069 * event history
17070
17071       PARAMETER (NMXHKK=200000)
17072
17073       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17074      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17075      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17076
17077 * extended event history
17078       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17079      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17080      &                IHIST(2,NMXHKK)
17081
17082 * final state after inc step
17083       PARAMETER (MAXFSP=10)
17084       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17085
17086 * flags for input different options
17087       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17088       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17089      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17090
17091 * particle properties (BAMJET index convention)
17092       CHARACTER*8  ANAME
17093       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17094      &                IICH(210),IIBAR(210),K1(210),K2(210)
17095
17096 * Glauber formalism: collision properties
17097       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
17098      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
17099
17100 * nuclear potential
17101       LOGICAL LFERMI
17102       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17103      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17104      &                ETACOU(2),ICOUL,LFERMI
17105
17106 * parameter for intranuclear cascade
17107       LOGICAL LPAULI
17108       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17109
17110 * final state after intranuclear cascade step
17111       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
17112
17113 * nucleon-nucleon event-generator
17114       CHARACTER*8 CMODEL
17115       LOGICAL LPHOIN
17116       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
17117
17118 * statistics: residual nuclei
17119       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
17120      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
17121      &                NINCST(2,4),NINCEV(2),
17122      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
17123      &                NRESPB(2),NRESCH(2),NRESEV(4),
17124      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
17125      &                NEVAFI(2,2)
17126
17127       DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
17128      &          PCAS1(5),PNUC(5),BGTA(4),
17129      &          BGCAS(2),GACAS(2),BECAS(2),
17130      &          RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
17131
17132       DATA PDIF /0.545D0/
17133
17134       IREJ = 0
17135
17136 * update counter
17137       IF (NINCEV(1).NE.NEVHKK) THEN
17138          NINCEV(1) = NEVHKK
17139          NINCEV(2) = NINCEV(2)+1
17140       ENDIF
17141
17142 * "BAMJET-index" of this hadron
17143       IDCAS = IDBAM(IDXCAS)
17144       IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
17145
17146 * skip gammas, electrons, etc..
17147       IF (AAM(IDCAS).LT.TINY2) RETURN
17148
17149 * Lorentz-trsf. into projectile rest system
17150       IF (IP.GT.1) THEN
17151          CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17152      &               PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
17153      &               PCAS(1,4),IDCAS,-2)
17154          PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
17155          PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
17156          IF (PCAS(1,5).GT.ZERO) THEN
17157             PCAS(1,5) = SQRT(PCAS(1,5))
17158          ELSE
17159             PCAS(1,5) = AAM(IDCAS)
17160          ENDIF
17161          DO 20 K=1,3
17162             COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
17163    20    CONTINUE
17164 * Lorentz-parameters
17165 *   particle rest system --> projectile rest system
17166          BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
17167          GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
17168          BECAS(1) = BGCAS(1)/GACAS(1)
17169       ELSE
17170          DO 21 K=1,5
17171             PCAS(1,K) = ZERO
17172             IF (K.LE.3) COSCAS(1,K) = ZERO
17173    21    CONTINUE
17174          PTOCAS(1) = ZERO
17175          BGCAS(1)  = ZERO
17176          GACAS(1)  = ZERO
17177          BECAS(1)  = ZERO
17178       ENDIF
17179 * Lorentz-trsf. into target rest system
17180       IF (IT.GT.1) THEN
17181 * LEPTO: final state particles are already in target rest frame
17182 C        IF (MCGENE.EQ.3) THEN
17183 C           PCAS(2,1) = PHKK(1,IDXCAS)
17184 C           PCAS(2,2) = PHKK(2,IDXCAS)
17185 C           PCAS(2,3) = PHKK(3,IDXCAS)
17186 C           PCAS(2,4) = PHKK(4,IDXCAS)
17187 C        ELSE
17188             CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17189      &                  PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
17190      &                  PCAS(2,4),IDCAS,-3)
17191 C        ENDIF
17192          PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
17193          PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
17194          IF (PCAS(2,5).GT.ZERO) THEN
17195             PCAS(2,5) = SQRT(PCAS(2,5))
17196          ELSE
17197             PCAS(2,5) = AAM(IDCAS)
17198          ENDIF
17199          DO 22 K=1,3
17200             COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
17201    22    CONTINUE
17202 * Lorentz-parameters
17203 *   particle rest system --> target rest system
17204          BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
17205          GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
17206          BECAS(2) = BGCAS(2)/GACAS(2)
17207       ELSE
17208          DO 23 K=1,5
17209             PCAS(2,K) = ZERO
17210             IF (K.LE.3) COSCAS(2,K) = ZERO
17211    23    CONTINUE
17212          PTOCAS(2) = ZERO
17213          BGCAS(2)  = ZERO
17214          GACAS(2)  = ZERO
17215          BECAS(2)  = ZERO
17216       ENDIF
17217
17218 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
17219 * potential (see CONUCL)
17220       RNUC(1)  = (RPROJ+4.605D0*PDIF)*FM2MM
17221       RNUC(2)  = (RTARG+4.605D0*PDIF)*FM2MM
17222 * impact parameter (the projectile moving along z)
17223       BIMPC(1) = ZERO
17224       BIMPC(2) = BIMPAC*FM2MM
17225
17226 * get position of initial hadron in projectile/target rest-syst.
17227       DO 3 K=1,4
17228          VTXCAS(1,K) = WHKK(K,IDXCAS)
17229          VTXCAS(2,K) = VHKK(K,IDXCAS)
17230     3 CONTINUE
17231
17232       ICAS = 1
17233       I2   = 2
17234       IF (NCAS.EQ.-1) THEN
17235          ICAS = 2
17236          I2   = 1
17237       ENDIF
17238
17239       IF (PTOCAS(ICAS).LT.TINY10) THEN
17240          WRITE(LOUT,1000) PTOCAS
17241  1000    FORMAT(1X,'INUCAS:   warning! zero momentum of initial',
17242      &          '  hadron ',/,20X,2E12.4)
17243          GOTO 9999
17244       ENDIF
17245
17246 * reset spectator flags
17247       NSPE = 0
17248       IDXSPE(1) = 0
17249       IDXSPE(2) = 0
17250       IDSPE(1)  = 0
17251       IDSPE(2)  = 0
17252
17253 * formation length (in fm)
17254 C     IF (LCAS) THEN
17255 C        DEL0 = ZERO
17256 C     ELSE
17257          DEL0 = TAUFOR*BGCAS(ICAS)
17258          IF (ITAUVE.EQ.1) THEN
17259             AMT  = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
17260             DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
17261          ENDIF
17262 C     ENDIF
17263 *   sample from exp(-del/del0)
17264       DEL1   = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
17265 * save formation time
17266       TAUSA1 = DEL1/BGCAS(ICAS)
17267       REL1   = TAUSA1*BGCAS(I2)
17268
17269       DEL    = DEL1
17270       TAUSAM = DEL/BGCAS(ICAS)
17271       REL    = TAUSAM*BGCAS(I2)
17272
17273 * special treatment for negative particles unable to escape
17274 * nuclear potential (implemented for ap, pi-, K- only)
17275       LABSOR = .FALSE.
17276       IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
17277 *   threshold energy = nuclear potential + Coulomb potential
17278 *   (nuclear potential for hadron-nucleus interactions only)
17279          ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
17280          IF (PCAS(ICAS,4).LT.ETHR) THEN
17281             DO 4 K=1,5
17282                PCAS1(K) = PCAS(ICAS,K)
17283     4       CONTINUE
17284 *   "absorb" negative particle in nucleus
17285             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
17286             IF (IREJ1.NE.0) GOTO 9999
17287             IF (NSPE.GE.1) LABSOR = .TRUE.
17288          ENDIF
17289       ENDIF
17290
17291 * if the initial particle has not been absorbed proceed with
17292 * "normal" cascade
17293       IF (.NOT.LABSOR) THEN
17294
17295 *   calculate coordinates of hadron at the end of the formation zone
17296 *   transport-time and -step in the rest system where this step is
17297 *   treated
17298          DSTEP  = DEL*FM2MM
17299          DTIME  = DSTEP/BECAS(ICAS)
17300          RSTEP  = REL*FM2MM
17301          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17302             RTIME = RSTEP/BECAS(I2)
17303          ELSE
17304             RTIME = ZERO
17305          ENDIF
17306 *   save step whithout considering the overlapping region
17307          DSTEP1 = DEL1*FM2MM
17308          DTIME1 = DSTEP1/BECAS(ICAS)
17309          RSTEP1 = REL1*FM2MM
17310          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17311             RTIME1 = RSTEP1/BECAS(I2)
17312          ELSE
17313             RTIME1 = ZERO
17314          ENDIF
17315 *   transport to the end of the formation zone in this system
17316          DO 5 K=1,3
17317             VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
17318             VTXCA1(I2,K)   = VTXCAS(I2,K)  +RSTEP1*COSCAS(I2,K)
17319             VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
17320             VTXCAS(I2,K)   = VTXCAS(I2,K)  +RSTEP*COSCAS(I2,K)
17321     5    CONTINUE
17322          VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
17323          VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME1
17324          VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17325          VTXCAS(I2,4)   = VTXCAS(I2,4)  +RTIME
17326
17327          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17328             XCAS   = VTXCAS(ICAS,1)
17329             YCAS   = VTXCAS(ICAS,2)
17330             XNCLTA = BIMPAC*FM2MM
17331             RNCLPR = (RPROJ+RNUCLE)*FM2MM
17332             RNCLTA = (RTARG+RNUCLE)*FM2MM
17333 C           RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
17334 C           RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
17335 C           RNCLPR = (RPROJ)*FM2MM
17336 C           RNCLTA = (RTARG)*FM2MM
17337             RCASPR = SQRT( XCAS**2        +YCAS**2)
17338             RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
17339             IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
17340                IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
17341             ENDIF
17342          ENDIF
17343
17344 *   check if particle is already outside of the corresp. nucleus
17345          RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
17346      &                VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
17347          IF (RDIST.GE.RNUC(ICAS)) THEN
17348 *   here: IDCH is the generation of the final state part. starting
17349 *   with zero for hadronization products
17350 *   flag particles of generation 0 being outside the nuclei after
17351 *   formation time (to be used for excitation energy calculation)
17352             IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
17353      &         NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
17354             GOTO 9997
17355          ENDIF
17356          DIST   = DLARGE
17357          DISTP  = DLARGE
17358          DISTN  = DLARGE
17359          IDXP   = 0
17360          IDXN   = 0
17361
17362 *   already here: skip particles being outside HADRIN "energy-window"
17363 *   to avoid wasting of time
17364          NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
17365          IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
17366             NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
17367 C           WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
17368 C1002       FORMAT(1X,'INUCAS:   warning! momentum of particle with ',
17369 C    &             'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
17370 C    &             E12.4,', above or below HADRIN-thresholds',I6)
17371             NSPE = 0
17372             GOTO 9997
17373          ENDIF
17374
17375          DO 7 IDXHKK=1,NOINC
17376             I = IDXINC(IDXHKK)
17377 *   scan DTEVT1 for unwounded or excited nucleons
17378             IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
17379                DO 8 K=1,3
17380                   IF (ICAS.EQ.1) THEN
17381                      VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
17382                   ELSEIF (ICAS.EQ.2) THEN
17383                      VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
17384                   ENDIF
17385     8          CONTINUE
17386                POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
17387      &                  VTXDST(2)*COSCAS(ICAS,2)+
17388      &                  VTXDST(3)*COSCAS(ICAS,3)
17389 *   check if nucleon is situated in forward direction
17390                IF (POSNUC.GT.ZERO) THEN
17391 *   distance between hadron and this nucleon
17392                   DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17393      &                          VTXDST(3)**2)
17394 *   impact parameter
17395                   BIMNU2 = DISTNU**2-POSNUC**2
17396                   IF (BIMNU2.LT.ZERO) THEN
17397                      WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
17398  1001                FORMAT(1X,'INUCAS:   warning! inconsistent impact',
17399      &                      '  parameter ',/,20X,3E12.4)
17400                      GOTO 7
17401                   ENDIF
17402                   BIMNU  = SQRT(BIMNU2)
17403 *   maximum impact parameter to have interaction
17404                   IDNUC  = IDT_ICIHAD(IDHKK(I))
17405                   IDNUC1 = IDT_MCHAD(IDNUC)
17406                   IDCAS1 = IDT_MCHAD(IDCAS)
17407                   DO 19 K=1,5
17408                      PCAS1(K) = PCAS(ICAS,K)
17409                      PNUC(K)  = PHKK(K,I)
17410    19             CONTINUE
17411 * Lorentz-parameter for trafo into rest-system of target
17412                   DO 18 K=1,4
17413                      BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
17414    18             CONTINUE
17415 * transformation of projectile into rest-system of target
17416                   CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
17417      &                        PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
17418      &                        PPTOT,PX,PY,PZ,PE)
17419 **
17420 C                 CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
17421 C                 CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
17422                   DUMZER = ZERO
17423                   CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
17424                   CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
17425                   IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
17426      &                (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
17427                   SIGIN = SIGTOT-SIGEL-SIGAB
17428 C                 SIGTOT = SIGIN+SIGEL+SIGAB
17429 **
17430                   BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
17431 *   check if interaction is possible
17432                   IF (BIMNU.LE.BIMMAX) THEN
17433 *   get nucleon with smallest distance and kind of interaction
17434 *   (elastic/inelastic)
17435                      IF (DISTNU.LT.DIST) THEN
17436                         DIST      = DISTNU
17437                         BINT      = BIMNU
17438                         IF (IDNUC.NE.IDSPE(1)) THEN
17439                            IDSPE(2)  = IDSPE(1)
17440                            IDXSPE(2) = IDXSPE(1)
17441                            IDSPE(1)  = IDNUC
17442                         ENDIF
17443                         IDXSPE(1) = I
17444                         NSPE      = 1
17445 **sr
17446                         SELA = SIGEL
17447                         SABS = SIGAB
17448                         STOT = SIGTOT
17449 C                       IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
17450 C                          SELA = SIGEL
17451 C                          STOT = SIGIN+SIGEL
17452 C                       ELSE
17453 C                          SELA = SIGEL+0.75D0*SIGIN
17454 C                          STOT = 0.25D0*SIGIN+SELA
17455 C                       ENDIF
17456 **
17457                      ENDIF
17458                   ENDIf
17459                ENDIF
17460                DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17461      &                       VTXDST(3)**2)
17462                IDNUC  = IDT_ICIHAD(IDHKK(I))
17463                IF (IDNUC.EQ.1) THEN
17464                   IF (DISTNU.LT.DISTP) THEN
17465                      DISTP = DISTNU
17466                      IDXP  = I
17467                      POSP  = POSNUC
17468                   ENDIF
17469                ELSEIF (IDNUC.EQ.8) THEN
17470                   IF (DISTNU.LT.DISTN) THEN
17471                      DISTN = DISTNU
17472                      IDXN  = I
17473                      POSN  = POSNUC
17474                   ENDIF
17475                ENDIF
17476             ENDIF
17477     7    CONTINUE
17478
17479 * there is no nucleon for a secondary interaction
17480          IF (NSPE.EQ.0) GOTO 9997
17481
17482 C        IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
17483 C    &      WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
17484          IF (IDXSPE(2).EQ.0) THEN
17485             IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
17486 C              DO 80 K=1,3
17487 C                 IF (ICAS.EQ.1) THEN
17488 C                    VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
17489 C                 ELSEIF (ICAS.EQ.2) THEN
17490 C                    VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
17491 C                 ENDIF
17492 C  80          CONTINUE
17493 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17494 C    &                       VTXDST(3)**2)
17495 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
17496                   IDXSPE(2) = IDXN
17497                   IDSPE(2)  = 8
17498 C              ELSE
17499 C                 STOT = STOT-SABS
17500 C                 SABS = ZERO
17501 C              ENDIF
17502             ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
17503 C              DO 81 K=1,3
17504 C                 IF (ICAS.EQ.1) THEN
17505 C                    VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
17506 C                 ELSEIF (ICAS.EQ.2) THEN
17507 C                    VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
17508 C                 ENDIF
17509 C  81          CONTINUE
17510 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17511 C    &                       VTXDST(3)**2)
17512 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
17513                   IDXSPE(2) = IDXP
17514                   IDSPE(2)  = 1
17515 C              ELSE
17516 C                 STOT = STOT-SABS
17517 C                 SABS = ZERO
17518 C              ENDIF
17519             ELSE
17520                STOT = STOT-SABS
17521                SABS = ZERO
17522             ENDIF
17523          ENDIF
17524          RR = DT_RNDM(DIST)
17525          IF (RR.LT.SELA/STOT) THEN
17526             IPROC = 2
17527          ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
17528             IPROC = 3
17529          ELSE
17530             IPROC = 1
17531          ENDIF
17532
17533          DO 9 K=1,5
17534             PCAS1(K) = PCAS(ICAS,K)
17535             PNUC(K)  = PHKK(K,IDXSPE(1))
17536     9    CONTINUE
17537          IF (IPROC.EQ.3) THEN
17538 * 2-nucleon absorption of pion
17539             NSPE = 2
17540             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
17541             IF (IREJ1.NE.0) GOTO 9999
17542             IF (NSPE.GE.1) LABSOR = .TRUE.
17543          ELSE
17544 * sample secondary interaction
17545             IDNUC = IDBAM(IDXSPE(1))
17546             CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
17547             IF (IREJ1.EQ.1) GOTO 9999
17548             IF (IREJ1.GT.1) GOTO 9998
17549          ENDIF
17550       ENDIF
17551
17552 * update arrays to include Pauli-principle
17553       DO 10 I=1,NSPE
17554          IF (NWOUND(ICAS).LE.299) THEN
17555             NWOUND(ICAS) = NWOUND(ICAS)+1
17556             EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
17557          ENDIF
17558    10 CONTINUE
17559
17560 * dump initial hadron for energy-momentum conservation check
17561       IF (LEMCCK)
17562      &   CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
17563      &               PCAS(ICAS,4),1,IDUM,IDUM)
17564
17565 * dump final state particles into DTEVT1
17566
17567 *   check if Pauli-principle is fulfilled
17568       NPAULI = 0
17569       NWTMP(1) = NWOUND(1)
17570       NWTMP(2) = NWOUND(2)
17571       DO 111 I=1,NFSP
17572          NPAULI = 0
17573          J1 = 2
17574          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17575      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
17576          DO 117 J=1,J1
17577             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
17578             IF (J.EQ.1) THEN
17579                IDX = ICAS
17580                PE  = PFSP(4,I)
17581             ELSE
17582                IDX  = I2
17583                MODE = 1
17584                IF (IDX.EQ.1) MODE = -1
17585                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
17586             ENDIF
17587 * first check if cascade step is forbidden due to Pauli-principle
17588 * (in case of absorpion this step is forced)
17589             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17590      &          (IDFSP(I).EQ.8))) THEN
17591 *   get nuclear potential barrier
17592                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17593                IF (IDFSP(I).EQ.1) THEN
17594                   POTLOW = POT-EBINDP(IDX)
17595                ELSE
17596                   POTLOW = POT-EBINDN(IDX)
17597                ENDIF
17598 *   final state particle not able to escape nucleus
17599                IF (PE.LE.POTLOW) THEN
17600 *     check if there are wounded nucleons
17601                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17602      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
17603                      NPAULI      = NPAULI+1
17604                      NWOUND(IDX) = NWOUND(IDX)-1
17605                   ELSE
17606 *     interaction prohibited by Pauli-principle
17607                      NWOUND(1) = NWTMP(1)
17608                      NWOUND(2) = NWTMP(2)
17609                      GOTO 9997
17610                   ENDIF
17611                ENDIF
17612             ENDIF
17613   117    CONTINUE
17614   111 CONTINUE
17615
17616       NPAULI = 0
17617       NWOUND(1) = NWTMP(1)
17618       NWOUND(2) = NWTMP(2)
17619
17620       DO 11 I=1,NFSP
17621
17622          IST = ISTHKK(IDXCAS)
17623
17624          NPAULI = 0
17625          J1 = 2
17626          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17627      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
17628          DO 17 J=1,J1
17629             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
17630             IDX = ICAS
17631             PE  = PFSP(4,I)
17632             IF (J.EQ.2) THEN
17633                IDX = I2
17634                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
17635             ENDIF
17636 * first check if cascade step is forbidden due to Pauli-principle
17637 * (in case of absorpion this step is forced)
17638             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17639      &          (IDFSP(I).EQ.8))) THEN
17640 *   get nuclear potential barrier
17641                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17642                IF (IDFSP(I).EQ.1) THEN
17643                   POTLOW = POT-EBINDP(IDX)
17644                ELSE
17645                   POTLOW = POT-EBINDN(IDX)
17646                ENDIF
17647 *   final state particle not able to escape nucleus
17648                IF (PE.LE.POTLOW) THEN
17649 *     check if there are wounded nucleons
17650                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17651      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
17652                      NWOUND(IDX) = NWOUND(IDX)-1
17653                      NPAULI = NPAULI+1
17654                      IST    = 14+IDX
17655                   ELSE
17656 *     interaction prohibited by Pauli-principle
17657                      NWOUND(1) = NWTMP(1)
17658                      NWOUND(2) = NWTMP(2)
17659                      GOTO 9997
17660                   ENDIF
17661 **sr
17662 c               ELSEIF (PE.LE.POT) THEN
17663 cC              ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
17664 cC                 NWOUND(IDX) = NWOUND(IDX)-1
17665 c**
17666 c                  NPAULI = NPAULI+1
17667 c                  IST    = 14+IDX
17668                ENDIF
17669             ENDIF
17670    17    CONTINUE
17671
17672 * dump final state particles for energy-momentum conservation check
17673          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
17674      &                           -PFSP(4,I),2,IDUM,IDUM)
17675
17676          PX = PFSP(1,I)
17677          PY = PFSP(2,I)
17678          PZ = PFSP(3,I)
17679          PE = PFSP(4,I)
17680          IF (ABS(IST).EQ.1) THEN
17681 * transform particles back into n-n cms
17682 * LEPTO: leave final state particles in target rest frame
17683 C           IF (MCGENE.EQ.3) THEN
17684 C              PFSP(1,I) = PX
17685 C              PFSP(2,I) = PY
17686 C              PFSP(3,I) = PZ
17687 C              PFSP(4,I) = PE
17688 C           ELSE
17689                IMODE = ICAS+1
17690                CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17691      &                     PFSP(4,I),IDFSP(I),IMODE)
17692 C           ENDIF
17693          ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
17694 * target cascade but fsp got stuck in proj. --> transform it into
17695 * proj. rest system
17696             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17697      &                  PFSP(4,I),IDFSP(I),-1)
17698          ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
17699 * proj. cascade but fsp got stuck in target --> transform it into
17700 * target rest system
17701             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17702      &                  PFSP(4,I),IDFSP(I),1)
17703          ENDIF
17704
17705 * dump final state particles into DTEVT1
17706          IGEN = IDCH(IDXCAS)+1
17707          ID   = IDT_IPDGHA(IDFSP(I))
17708          IXR  = 0
17709          IF (LABSOR) IXR = 99
17710          CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
17711      &               PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
17712
17713 * update the counter for particles which got stuck inside the nucleus
17714          IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
17715             NOINC = NOINC+1
17716             IDXINC(NOINC) = NHKK
17717          ENDIF
17718          IF (LABSOR) THEN
17719 *   in case of absorption the spatial treatment is an approximate
17720 *   solution anyway (the positions of the nucleons which "absorb" the
17721 *   cascade particle are not taken into consideration) therefore the
17722 *   particles are produced at the position of the cascade particle
17723             DO 12 K=1,4
17724                WHKK(K,NHKK) = WHKK(K,IDXCAS)
17725                VHKK(K,NHKK) = VHKK(K,IDXCAS)
17726    12       CONTINUE
17727          ELSE
17728 *   DDISTL - distance the cascade particle moves to the intera. point
17729 *   (the position where impact-parameter = distance to the interacting
17730 *   nucleon), DIST - distance to the interacting nucleon at the time of
17731 *   formation of the cascade particle, BINT - impact-parameter of this
17732 *   cascade-interaction
17733             DDISTL = SQRT(DIST**2-BINT**2)
17734             DTIME  = DDISTL/BECAS(ICAS)
17735             DTIMEL = DDISTL/BGCAS(ICAS)
17736             RDISTL = DTIMEL*BGCAS(I2)
17737             IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17738                RTIME = RDISTL/BECAS(I2)
17739             ELSE
17740                RTIME = ZERO
17741             ENDIF
17742 *   RDISTL, RTIME are this step and time in the rest system of the other
17743 *   nucleus
17744             DO 13 K=1,3
17745                VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
17746                VTXCA1(I2,K)   = VTXCAS(I2,K)  +COSCAS(I2,K)  *RDISTL
17747    13       CONTINUE
17748             VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17749             VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME
17750 *   position of particle production is half the impact-parameter to
17751 *   the interacting nucleon
17752             DO 14 K=1,3
17753                WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
17754                VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
17755    14       CONTINUE
17756 *   time of production of secondary = time of interaction
17757             WHKK(4,NHKK) = VTXCA1(1,4)
17758             VHKK(4,NHKK) = VTXCA1(2,4)
17759          ENDIF
17760
17761    11 CONTINUE
17762
17763 * modify status and position of cascade particle (the latter for
17764 * statistics reasons only)
17765       ISTHKK(IDXCAS) = 2
17766       IF (LABSOR) ISTHKK(IDXCAS) = 19
17767       IF (.NOT.LABSOR) THEN
17768          DO 15 K=1,4
17769             WHKK(K,IDXCAS) = VTXCA1(1,K)
17770             VHKK(K,IDXCAS) = VTXCA1(2,K)
17771    15    CONTINUE
17772       ENDIF
17773
17774       DO 16 I=1,NSPE
17775          IS = IDXSPE(I)
17776 * dump interacting nucleons for energy-momentum conservation check
17777          IF (LEMCCK)
17778      &      CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
17779      &                                                  2,IDUM,IDUM)
17780 * modify entry for interacting nucleons
17781          IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
17782          IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
17783          IF (I.GE.2) THEN
17784             JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
17785             JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
17786          ENDIF
17787    16 CONTINUE
17788
17789 * check energy-momentum conservation
17790       IF (LEMCCK) THEN
17791          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
17792          IF (IREJ1.NE.0) GOTO 9999
17793       ENDIF
17794
17795 * update counter
17796       IF (LABSOR) THEN
17797          NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
17798       ELSE
17799          IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
17800          IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
17801       ENDIF
17802
17803       RETURN
17804
17805  9997 CONTINUE
17806  9998 CONTINUE
17807 * transport-step but no cascade step due to configuration (i.e. there
17808 * is no nucleon for interaction etc.)
17809       IF (LCAS) THEN
17810          DO 100 K=1,4
17811 C           WHKK(K,IDXCAS) = VTXCAS(1,K)
17812 C           VHKK(K,IDXCAS) = VTXCAS(2,K)
17813             WHKK(K,IDXCAS) = VTXCA1(1,K)
17814             VHKK(K,IDXCAS) = VTXCA1(2,K)
17815   100    CONTINUE
17816       ENDIF
17817
17818 C9998 CONTINUE
17819 * no cascade-step because of configuration
17820 * (i.e. hadron outside nucleus etc.)
17821       LCAS = .TRUE.
17822       RETURN
17823
17824  9999 CONTINUE
17825 * rejection
17826       IREJ = 1
17827       RETURN
17828       END
17829
17830 *$ CREATE DT_ABSORP.FOR
17831 *COPY DT_ABSORP
17832 *
17833 *===absorp=============================================================*
17834 *
17835       SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
17836
17837 ************************************************************************
17838 * Two-nucleon absorption of antiprotons, pi-, and K-.                  *
17839 * Antiproton absorption is handled by HADRIN.                          *
17840 * The following channels for meson-absorption are considered:          *
17841 *          pi- + p + p ---> n + p                                      *
17842 *          pi- + p + n ---> n + n                                      *
17843 *          K-  + p + p ---> sigma+ + n / Lam + p / sigma0 + p          *
17844 *          K-  + p + n ---> sigma- + n / Lam + n / sigma0 + n          *
17845 *          K-  + p + p ---> sigma- + n                                 *
17846 *      IDCAS, PCAS   identity, momentum of particle to be absorbed     *
17847 *      NCAS =  1     intranuclear cascade in projectile                *
17848 *           = -1     intranuclear cascade in target                    *
17849 *      NSPE          number of spectator nucleons involved             *
17850 *      IDXSPE(2)     DTEVT1-indices of spectator nucleons involved     *
17851 * Revised version of the original STOPIK written by HJM and J. Ranft.  *
17852 * This version dated 24.02.95 is written by S. Roesler                 *
17853 ************************************************************************
17854
17855       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17856       SAVE
17857
17858       PARAMETER ( LINP = 10 ,
17859      &            LOUT = 6 ,
17860      &            LDAT = 9 )
17861
17862       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17863      &           ONETHI=0.3333D0,TWOTHI=0.6666D0)
17864
17865 * event history
17866
17867       PARAMETER (NMXHKK=200000)
17868
17869       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17870      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17871      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17872
17873 * extended event history
17874       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17875      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17876      &                IHIST(2,NMXHKK)
17877
17878 * flags for input different options
17879       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17880       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17881      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17882
17883 * final state after inc step
17884       PARAMETER (MAXFSP=10)
17885       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17886
17887 * particle properties (BAMJET index convention)
17888       CHARACTER*8  ANAME
17889       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17890      &                IICH(210),IIBAR(210),K1(210),K2(210)
17891
17892       DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17893      &          PTOT3P(4),BG3P(4),
17894      &          ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17895
17896       IREJ = 0
17897       NFSP = 0
17898
17899 * skip particles others than ap, pi-, K- for mode=0
17900       IF ((MODE.EQ.0).AND.
17901      &    (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17902 * skip particles others than pions for mode=1
17903 * (2-nucleon absorption in intranuclear cascade)
17904       IF ((MODE.EQ.1).AND.
17905      &    (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17906
17907       NUCAS = NCAS
17908       IF (NUCAS.EQ.-1) NUCAS = 2
17909
17910       IF (MODE.EQ.0) THEN
17911 * scan spectator nucleons for nucleons being able to "absorb"
17912          NSPE      = 0
17913          IDXSPE(1) = 0
17914          IDXSPE(2) = 0
17915          DO 1 I=1,NHKK
17916             IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17917                NSPE         = NSPE+1
17918                IDXSPE(NSPE) = I
17919                IDSPE(NSPE)  = IDBAM(I)
17920                IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17921                IF (NSPE.EQ.2) THEN
17922                   IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17923      &                                  (IDSPE(2).EQ.8)) THEN
17924 *    there is no pi-+n+n channel
17925                      NSPE = 1
17926                      GOTO 1
17927                   ELSE
17928                      GOTO 2
17929                   ENDIF
17930                ENDIF
17931             ENDIF
17932     1    CONTINUE
17933
17934     2    CONTINUE
17935       ENDIF
17936 * transform excited projectile nucleons (status=15) into proj. rest s.
17937       DO 3 I=1,NSPE
17938          DO 4 K=1,5
17939             PSPE(I,K) = PHKK(K,IDXSPE(I))
17940     4    CONTINUE
17941     3 CONTINUE
17942
17943 * antiproton absorption
17944       IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17945          DO 5 K=1,5
17946             PSPE1(K) = PSPE(1,K)
17947     5    CONTINUE
17948          CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17949          IF (IREJ1.NE.0) GOTO 9999
17950
17951 * meson absorption
17952       ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17953      &                      .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17954          IF (IDCAS.EQ.14) THEN
17955 *   pi- absorption
17956             IDFSP(1) = 8
17957             IDFSP(2) = 8
17958             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17959          ELSEIF (IDCAS.EQ.13) THEN
17960 *   pi+ absorption
17961             IDFSP(1) = 1
17962             IDFSP(2) = 1
17963             IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17964          ELSEIF (IDCAS.EQ.23) THEN
17965 *   pi0 absorption
17966             IDFSP(1) = IDSPE(1)
17967             IDFSP(2) = IDSPE(2)
17968          ELSEIF (IDCAS.EQ.16) THEN
17969 *   K- absorption
17970             R = DT_RNDM(PCAS)
17971             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17972                IF (R.LT.ONETHI) THEN
17973                   IDFSP(1) = 21
17974                   IDFSP(2) = 8
17975                ELSEIF (R.LT.TWOTHI) THEN
17976                   IDFSP(1) = 17
17977                   IDFSP(2) = 1
17978                ELSE
17979                   IDFSP(1) = 22
17980                   IDFSP(2) = 1
17981                ENDIF
17982             ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17983                IDFSP(1) = 20
17984                IDFSP(2) = 8
17985             ELSE
17986                IF (R.LT.ONETHI) THEN
17987                   IDFSP(1) = 20
17988                   IDFSP(2) = 1
17989                ELSEIF (R.LT.TWOTHI) THEN
17990                   IDFSP(1) = 17
17991                   IDFSP(2) = 8
17992                ELSE
17993                   IDFSP(1) = 22
17994                   IDFSP(2) = 8
17995                ENDIF
17996             ENDIF
17997          ENDIF
17998 *   dump initial particles for energy-momentum cons. check
17999          IF (LEMCCK) THEN
18000             CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
18001             CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
18002      &                                                    IDUM,IDUM)
18003             CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
18004      &                                                    IDUM,IDUM)
18005          ENDIF
18006 *   get Lorentz-parameter of 3 particle initial state
18007          DO 6 K=1,4
18008             PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
18009     6    CONTINUE
18010          P3P  = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
18011          AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
18012          DO 7 K=1,4
18013             BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
18014     7    CONTINUE
18015 *   2-particle decay of the 3-particle compound system
18016          CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
18017      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
18018      &               AAM(IDFSP(1)),AAM(IDFSP(2)))
18019          DO 8 I=1,2
18020             SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
18021             PX  = PCMF(I)*COFF(I)*SDF
18022             PY  = PCMF(I)*SIFF(I)*SDF
18023             PZ  = PCMF(I)*CODF(I)
18024             CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
18025      &                  ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
18026      &                  PFSP(4,I))
18027             PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
18028 *   check consistency of kinematics
18029             IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
18030                WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
18031  1001          FORMAT(1X,'ABSORP:   warning! inconsistent',
18032      &                ' tree-particle kinematics',/,20X,'id: ',I3,
18033      &                ' AAM = ',E10.4,' MFSP = ',E10.4)
18034             ENDIF
18035 *   dump final state particles for energy-momentum cons. check
18036             IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18037      &                              -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18038     8    CONTINUE
18039          NFSP = 2
18040          IF (LEMCCK) THEN
18041             CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
18042             IF (IREJ1.NE.0) THEN
18043                WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
18044      &                      AM3P
18045                GOTO 9999
18046             ENDIF
18047          ENDIF
18048       ELSE
18049          IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
18050  1000    FORMAT(1X,'ABSORP:   warning! absorption for particle ',I3,
18051      &          ' impossible',/,20X,'too few spectators (',I2,')')
18052          NSPE = 0
18053       ENDIF
18054
18055       RETURN
18056
18057  9999 CONTINUE
18058       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
18059       IREJ = 1
18060       RETURN
18061       END
18062
18063 *$ CREATE DT_HADRIN.FOR
18064 *COPY DT_HADRIN
18065 *
18066 *===hadrin=============================================================*
18067 *
18068       SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
18069
18070 ************************************************************************
18071 * Interface to the HADRIN-routines for inelastic and elastic           *
18072 * scattering.                                                          *
18073 *      IDPR,PPR(5)   identity, momentum of projectile                  *
18074 *      IDTA,PTA(5)   identity, momentum of target                      *
18075 *      MODE  = 1     inelastic interaction                             *
18076 *            = 2     elastic   interaction                             *
18077 * Revised version of the original FHAD.                                *
18078 * This version dated 27.10.95 is written by S. Roesler                 *
18079 ************************************************************************
18080
18081       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18082       SAVE
18083
18084       PARAMETER ( LINP = 10 ,
18085      &            LOUT = 6 ,
18086      &            LDAT = 9 )
18087
18088       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
18089      &           TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
18090
18091       LOGICAL LCORR,LMSSG
18092
18093 * flags for input different options
18094       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18095       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18096      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18097
18098 * final state after inc step
18099       PARAMETER (MAXFSP=10)
18100       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18101
18102 * particle properties (BAMJET index convention)
18103       CHARACTER*8  ANAME
18104       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18105      &                IICH(210),IIBAR(210),K1(210),K2(210)
18106 * output-common for DHADRI/ELHAIN
18107
18108 * final state from HADRIN interaction
18109       PARAMETER (MAXFIN=10)
18110       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
18111      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
18112
18113       DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
18114      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
18115
18116       DATA LMSSG /.TRUE./
18117
18118       IREJ  = 0
18119       NFSP  = 0
18120       KCORR = 0
18121       IMCORR(1) = 0
18122       IMCORR(2) = 0
18123       LCORR = .FALSE.
18124
18125 *   dump initial particles for energy-momentum cons. check
18126       IF (LEMCCK) THEN
18127          CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
18128          CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
18129       ENDIF
18130
18131       AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
18132       AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
18133       IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
18134      &    (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
18135      &    (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
18136          IF (LMSSG.AND.(IOULEV(3).GT.0))
18137      &   WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
18138  1000    FORMAT(1X,'HADRIN:   warning! inconsistent projectile/target',
18139      &          ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
18140      &          E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
18141          LMSSG = .FALSE.
18142          LCORR = .TRUE.
18143       ENDIF
18144
18145 * convert initial state particles into particles which can be
18146 * handled by HADRIN
18147       IDHPR = IDPR
18148       IDHTA = IDTA
18149       IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
18150          IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
18151          DO 1 K=1,4
18152             P1IN(K) = PPR(K)
18153             P2IN(K) = PTA(K)
18154     1    CONTINUE
18155          XM1 = AAM(IDHPR)
18156          XM2 = AAM(IDHTA)
18157          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18158          IF (IREJ1.GT.0) THEN
18159             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
18160             GOTO 9999
18161          ENDIF
18162          DO 2 K=1,4
18163             PPR(K) = P1OUT(K)
18164             PTA(K) = P2OUT(K)
18165     2    CONTINUE
18166          PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
18167          PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
18168       ENDIF
18169
18170 * Lorentz-parameter for trafo into rest-system of target
18171       DO 3 K=1,4
18172          BGTA(K) = PTA(K)/PTA(5)
18173     3 CONTINUE
18174 * transformation of projectile into rest-system of target
18175       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
18176      &            PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
18177      &            PPR1(4))
18178
18179 * direction cosines of projectile in target rest system
18180       CX = PPR1(1)/PPRTO1
18181       CY = PPR1(2)/PPRTO1
18182       CZ = PPR1(3)/PPRTO1
18183
18184 * sample inelastic interaction
18185       IF (MODE.EQ.1) THEN
18186          CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
18187          IF (IRH.EQ.1) GOTO 9998
18188 * sample elastic interaction
18189       ELSEIF (MODE.EQ.2) THEN
18190          CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
18191          IF (IREJ1.NE.0) THEN
18192             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
18193             GOTO 9999
18194          ENDIF
18195          IF (IRH.EQ.1) GOTO 9998
18196       ELSE
18197          WRITE(LOUT,1001) MODE,INTHAD
18198  1001    FORMAT(1X,'HADRIN:   warning! inconsistent interaction mode',
18199      &          I4,' (INTHAD =',I4,')')
18200          GOTO 9999
18201       ENDIF
18202
18203 * transform final state particles back into Lab.
18204       DO 4 I=1,IRH
18205          NFSP = NFSP+1
18206          PX   = CXRH(I)*PLRH(I)
18207          PY   = CYRH(I)*PLRH(I)
18208          PZ   = CZRH(I)*PLRH(I)
18209          CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
18210      &               PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
18211      &               PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
18212          IDFSP(NFSP) = ITRH(I)
18213          AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
18214      &                                            PFSP(3,NFSP)**2
18215          IF (AMFSP2.LT.-TINY3) THEN
18216             WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
18217      &                       PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
18218  1002       FORMAT(1X,'HADRIN:   warning! final state particle (id = ',
18219      &             I2,') with negative mass^2',/,1X,5E12.4)
18220             GOTO 9999
18221          ELSE
18222             PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
18223             IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
18224                WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
18225      &                          PFSP(5,NFSP)
18226  1003          FORMAT(1X,'HADRIN:   warning! final state particle',
18227      &                ' (id = ',I2,') with inconsistent mass',/,1X,
18228      &                2E12.4)
18229                KCORR         = KCORR+1
18230                IF (KCORR.GT.2) GOTO 9999
18231                IMCORR(KCORR) = NFSP
18232             ENDIF
18233          ENDIF
18234 *   dump final state particles for energy-momentum cons. check
18235          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18236      &                           -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18237     4 CONTINUE
18238
18239 * transform momenta on mass shell in case of inconsistencies in
18240 * HADRIN
18241       IF (KCORR.GT.0) THEN
18242          IF (KCORR.EQ.2) THEN
18243             I1 = IMCORR(1)
18244             I2 = IMCORR(2)
18245          ELSE
18246             IF (IMCORR(1).EQ.1) THEN
18247                I1 = 1
18248                I2 = 2
18249             ELSE
18250                I1 = 1
18251                I2 = IMCORR(1)
18252             ENDIF
18253          ENDIF
18254          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
18255      &                           PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
18256          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
18257      &                           PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
18258          DO 5 K=1,4
18259             P1IN(K) = PFSP(K,I1)
18260             P2IN(K) = PFSP(K,I2)
18261     5    CONTINUE
18262          XM1 = AAM(IDFSP(I1))
18263          XM2 = AAM(IDFSP(I2))
18264          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18265          IF (IREJ1.GT.0) THEN
18266             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
18267 C           GOTO 9999
18268          ENDIF
18269          DO 6 K=1,4
18270             PFSP(K,I1) = P1OUT(K)
18271             PFSP(K,I2) = P2OUT(K)
18272     6    CONTINUE
18273          PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
18274      &                    -PFSP(2,I1)**2-PFSP(3,I1)**2)
18275          PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
18276      &                    -PFSP(2,I2)**2-PFSP(3,I2)**2)
18277 *   dump final state particles for energy-momentum cons. check
18278          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
18279      &                           -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
18280          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
18281      &                           -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
18282       ENDIF
18283
18284 * check energy-momentum conservation
18285       IF (LEMCCK) THEN
18286          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
18287          IF (IREJ1.NE.0) GOTO 9999
18288       ENDIF
18289
18290       RETURN
18291
18292  9998 CONTINUE
18293       IREJ = 2
18294       RETURN
18295
18296  9999 CONTINUE
18297       IREJ = 1
18298       RETURN
18299       END
18300
18301 *$ CREATE DT_HADCOL.FOR
18302 *COPY DT_HADCOL
18303 *
18304 *===hadcol=============================================================*
18305 *
18306       SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
18307
18308 ************************************************************************
18309 * Interface to the HADRIN-routines for inelastic and elastic           *
18310 * scattering. This subroutine samples hadron-nucleus interactions      *
18311 * below DPM-threshold.                                                 *
18312 *      IDPROJ        BAMJET-index of projectile hadron                 *
18313 *      PPN           projectile momentum in target rest frame          *
18314 *      IDXTAR        DTEVT1-index of target nucleon undergoing         *
18315 *                    interaction with projectile hadron                *
18316 * This subroutine replaces HADHAD.                                     *
18317 * This version dated 5.5.95 is written by S. Roesler                   *
18318 ************************************************************************
18319
18320       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18321       SAVE
18322
18323       PARAMETER ( LINP = 10 ,
18324      &            LOUT = 6 ,
18325      &            LDAT = 9 )
18326
18327       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
18328
18329       LOGICAL LSTART
18330
18331 * event history
18332
18333       PARAMETER (NMXHKK=200000)
18334
18335       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18336      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18337      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18338
18339 * extended event history
18340       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18341      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18342      &                IHIST(2,NMXHKK)
18343
18344 * nuclear potential
18345       LOGICAL LFERMI
18346       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18347      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18348      &                ETACOU(2),ICOUL,LFERMI
18349
18350 * interface HADRIN-DPM
18351       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
18352
18353 * parameter for intranuclear cascade
18354       LOGICAL LPAULI
18355       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
18356
18357 * final state after inc step
18358       PARAMETER (MAXFSP=10)
18359       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18360
18361 * particle properties (BAMJET index convention)
18362       CHARACTER*8  ANAME
18363       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18364      &                IICH(210),IIBAR(210),K1(210),K2(210)
18365
18366       DIMENSION PPROJ(5),PNUC(5)
18367
18368       DATA LSTART /.TRUE./
18369
18370       IREJ   = 0
18371
18372       NPOINT(1) = NHKK+1
18373
18374       TAUSAV = TAUFOR
18375 **sr 6/9/01 commented
18376 C     TAUFOR = TAUFOR/2.0D0
18377 **
18378       IF (LSTART) THEN
18379          WRITE(LOUT,1000)
18380  1000    FORMAT(/,1X,'HADCOL:  Scattering handled by HADRIN')
18381          WRITE(LOUT,1001) TAUFOR
18382  1001    FORMAT(/,1X,'HADCOL:  Formation zone parameter set to ',
18383      &          F5.1,' fm/c')
18384          LSTART = .FALSE.
18385       ENDIF
18386
18387       IDNUC  = IDBAM(IDXTAR)
18388       IDNUC1 = IDT_MCHAD(IDNUC)
18389       IDPRO1 = IDT_MCHAD(IDPROJ)
18390
18391       IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
18392          IPROC = INTHAD
18393       ELSE
18394 **
18395 C        CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
18396 C        CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
18397          DUMZER = ZERO
18398          CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
18399          SIGIN = SIGTOT-SIGEL
18400 C        SIGTOT = SIGIN+SIGEL
18401 **
18402          IPROC  = 1
18403          IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
18404       ENDIF
18405
18406       PPROJ(1) = ZERO
18407       PPROJ(2) = ZERO
18408       PPROJ(3) = PPN
18409       PPROJ(5) = AAM(IDPROJ)
18410       PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
18411       DO 1 K=1,5
18412          PNUC(K)  = PHKK(K,IDXTAR)
18413     1 CONTINUE
18414
18415       ILOOP = 0
18416     2 CONTINUE
18417       ILOOP = ILOOP+1
18418       IF (ILOOP.GT.100) GOTO 9999
18419
18420       CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
18421       IF (IREJ1.EQ.1) GOTO 9999
18422
18423       IF (IREJ1.GT.1) THEN
18424 * no interaction possible
18425 *   require Pauli blocking
18426          IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
18427          IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
18428          IF ((IIBAR(IDPROJ).NE.1).AND.
18429      &       (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5)))              GOTO 2
18430 *   store incoming particle as final state particle
18431          CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
18432          CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
18433          NPOINT(4) = NHKK
18434       ELSE
18435 * require Pauli blocking for final state nucleons
18436          DO 4 I=1,NFSP
18437             IF ((IDFSP(I).EQ.1).AND.
18438      &          (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I))))       GOTO 2
18439             IF ((IDFSP(I).EQ.8).AND.
18440      &          (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I))))       GOTO 2
18441             IF ((IIBAR(IDFSP(I)).NE.1).AND.
18442      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
18443     4    CONTINUE
18444 * store final state particles
18445          DO 5 I=1,NFSP
18446             IST = 1
18447             IF ((IIBAR(IDFSP(I)).EQ.1).AND.
18448      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
18449             IDHAD = IDT_IPDGHA(IDFSP(I))
18450             CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
18451             CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
18452      &                                        PCMS,ECMS,0,0,0)
18453             IF (I.EQ.1) NPOINT(4) = NHKK
18454             VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
18455             VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
18456             VHKK(3,NHKK) = VHKK(3,IDXTAR)
18457             VHKK(4,NHKK) = VHKK(4,IDXTAR)
18458             WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
18459             WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
18460             WHKK(3,NHKK) = WHKK(3,1)
18461             WHKK(4,NHKK) = WHKK(4,1)
18462     5    CONTINUE
18463       ENDIF
18464       TAUFOR = TAUSAV
18465       RETURN
18466
18467  9999 CONTINUE
18468       IREJ = 1
18469       TAUFOR = TAUSAV
18470       RETURN
18471       END
18472 *$ CREATE DT_GETEMU.FOR
18473 *COPY DT_GETEMU
18474 *
18475 *===getemu=============================================================*
18476 *
18477       SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
18478
18479 ************************************************************************
18480 * Sampling of emulsion component to be considered as target-nucleus.   *
18481 * This version dated 6.5.95   is written by S. Roesler.                *
18482 ************************************************************************
18483
18484       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18485       SAVE
18486
18487       PARAMETER ( LINP = 10 ,
18488      &            LOUT = 6 ,
18489      &            LDAT = 9 )
18490
18491       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18492
18493       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
18494
18495 * emulsion treatment
18496       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
18497      &                NCOMPO,IEMUL
18498
18499 * Glauber formalism: flags and parameters for statistics
18500       LOGICAL LPROD
18501       CHARACTER*8 CGLB
18502       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
18503
18504       IF (MODE.EQ.0) THEN
18505          SUMFRA = ZERO
18506          RR = DT_RNDM(SUMFRA)
18507          IT  = 0
18508          ITZ = 0
18509          DO 1 ICOMP=1,NCOMPO
18510             SUMFRA = SUMFRA+EMUFRA(ICOMP)
18511             IF (SUMFRA.GT.RR) THEN
18512                IT    = IEMUMA(ICOMP)
18513                ITZ   = IEMUCH(ICOMP)
18514                KKMAT = ICOMP
18515                GOTO 2
18516             ENDIF
18517     1    CONTINUE
18518     2    CONTINUE
18519          IF (IT.LE.0) THEN
18520             WRITE(LOUT,'(1X,A,E12.3)')
18521      &       'Warning!  norm. failure within emulsion fractions',
18522      &       SUMFRA
18523             STOP
18524          ENDIF
18525       ELSEIF (MODE.EQ.1) THEN
18526          NDIFF = 10000
18527          DO 3 I=1,NCOMPO
18528             IDIFF = ABS(IT-IEMUMA(I))
18529             IF (IDIFF.LT.NDIFF) THEN
18530                KKMAT = I
18531                NDIFF = IDIFF
18532             ENDIF
18533     3    CONTINUE
18534       ELSE
18535          STOP 'DT_GETEMU'
18536       ENDIF
18537
18538 * bypass for variable projectile/target/energy runs: the correct
18539 * Glauber data will be always loaded on kkmat=1
18540       IF (IOGLB.EQ.100) THEN
18541          KKMAT = 1
18542       ENDIF
18543
18544       RETURN
18545       END
18546
18547 *$ CREATE DT_NCLPOT.FOR
18548 *COPY DT_NCLPOT
18549 *
18550 *===nclpot=============================================================*
18551 *
18552       SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
18553
18554 ************************************************************************
18555 * Calculation of Coulomb and nuclear potential for a given configurat. *
18556 *               IPZ, IP       charge/mass number of proj.              *
18557 *               ITZ, IT       charge/mass number of targ.              *
18558 *               AFERP,AFERT   factors modifying proj./target pot.      *
18559 *                             if =0, FERMOD is used                    *
18560 *               MODE = 0      calculation of binding energy            *
18561 *                    = 1      pre-calculated binding energy is used    *
18562 * This version dated 16.11.95  is written by S. Roesler.               *
18563 *                                                                      *
18564 * Last change 28.12.2006 by S. Roesler.                                *
18565 ************************************************************************
18566
18567       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18568       SAVE
18569
18570       PARAMETER ( LINP = 10 ,
18571      &            LOUT = 6 ,
18572      &            LDAT = 9 )
18573
18574       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18575      &           TINY10=1.0D-10)
18576
18577       LOGICAL LSTART
18578
18579 * particle properties (BAMJET index convention)
18580       CHARACTER*8  ANAME
18581       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18582      &                IICH(210),IIBAR(210),K1(210),K2(210)
18583
18584 * nuclear potential
18585       LOGICAL LFERMI
18586       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18587      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18588      &                ETACOU(2),ICOUL,LFERMI
18589
18590       DIMENSION IDXPOT(14)
18591 *                   ap   an  lam  alam sig- sig+ sig0 tet0 tet- asig-
18592       DATA IDXPOT /   2,   9,  17,  18,  20,  21,  22,  97,  98,  99,
18593 *                 asig0 asig+ atet0 atet+
18594      &              100, 101, 102, 103/
18595
18596       DATA AN     /0.4D0/
18597       DATA LSTART /.TRUE./
18598
18599       IF (MODE.EQ.0) THEN
18600          EBINDP(1) = ZERO
18601          EBINDN(1) = ZERO
18602          EBINDP(2) = ZERO
18603          EBINDN(2) = ZERO
18604       ENDIF
18605       AIP  = DBLE(IP)
18606       AIPZ = DBLE(IPZ)
18607       AIT  = DBLE(IT)
18608       AITZ = DBLE(ITZ)
18609
18610       FERMIP = AFERP
18611       IF (AFERP.LE.ZERO) FERMIP = FERMOD
18612       FERMIT = AFERT
18613       IF (AFERT.LE.ZERO) FERMIT = FERMOD
18614
18615 * Fermi momenta and binding energy for projectile
18616       IF ((IP.GT.1).AND.LFERMI) THEN
18617          IF (MODE.EQ.0) THEN
18618 C           EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
18619 C           EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
18620             BIP  = AIP -ONE
18621             BIPZ = AIPZ-ONE
18622
18623 C           EBINDP(1) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIP,BIPZ)
18624 C    &                                         -ENERGY(AIP,AIPZ))
18625             EBINDP(1) = 1.0D-3*(EXMSAZ(ONE,ONE ,.TRUE.,IZDUM)
18626      &                         +EXMSAZ(BIP,BIPZ,.TRUE.,IZDUM)
18627      &                         -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18628
18629             IF (AIP.LE.AIPZ) THEN
18630                EBINDN(1) = EBINDP(1)
18631                WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
18632             ELSE
18633
18634 C              EBINDN(1) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIP,AIPZ)
18635 C    &                                             -ENERGY(AIP,AIPZ))
18636                EBINDN(1) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18637      &                            +EXMSAZ(BIP,AIPZ,.TRUE.,IZDUM)
18638      &                            -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18639
18640             ENDIF
18641          ENDIF
18642          PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
18643          PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
18644       ELSE
18645          PFERMP(1) = ZERO
18646          PFERMN(1) = ZERO
18647       ENDIF
18648 * effective nuclear potential for projectile
18649 C     EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
18650 C     EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
18651       EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
18652       EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
18653
18654 * Fermi momenta and binding energy for target
18655       IF ((IT.GT.1).AND.LFERMI) THEN
18656          IF (MODE.EQ.0) THEN
18657 C           EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
18658 C           EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
18659             BIT  = AIT -ONE
18660             BITZ = AITZ-ONE
18661
18662 C           EBINDP(2) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIT,BITZ)
18663 C    &                                         -ENERGY(AIT,AITZ))
18664             EBINDP(2) = 1.0D-3*(EXMSAZ(ONE,ONE, .TRUE.,IZDUM)
18665      &                         +EXMSAZ(BIT,BITZ,.TRUE.,IZDUM)
18666      &                         -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18667
18668             IF (AIT.LE.AITZ) THEN
18669                EBINDN(2) = EBINDP(2)
18670                WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
18671             ELSE
18672
18673 C              EBINDN(2) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIT,AITZ)
18674 C    &                                             -ENERGY(AIT,AITZ))
18675                EBINDN(2) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18676      &                            +EXMSAZ(BIT,AITZ,.TRUE.,IZDUM)
18677      &                            -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18678
18679             ENDIF
18680          ENDIF
18681          PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
18682          PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
18683       ELSE
18684          PFERMP(2) = ZERO
18685          PFERMN(2) = ZERO
18686       ENDIF
18687 * effective nuclear potential for target
18688 C     EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
18689 C     EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
18690       EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
18691       EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
18692
18693       DO 2 I=1,14
18694          EPOT(1,IDXPOT(I)) = EPOT(1,8)
18695          EPOT(2,IDXPOT(I)) = EPOT(2,8)
18696     2 CONTINUE
18697
18698 * Coulomb energy
18699       ETACOU(1) = ZERO
18700       ETACOU(2) = ZERO
18701       IF (ICOUL.EQ.1) THEN
18702          IF (IP.GT.1)
18703      &   ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
18704          IF (IT.GT.1)
18705      &   ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
18706       ENDIF
18707
18708       IF (LSTART) THEN
18709          WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
18710      &                    EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
18711      &                    EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
18712      &                    FERMOD,ETACOU
18713  1000    FORMAT(/,/,1X,'NCLPOT:    quantities for inclusion of nuclear'
18714      &           ,' effects',/,12X,'---------------------------',
18715      &           '----------------',/,/,38X,'projectile',
18716      &           '      target',/,/,1X,'Mass number / charge',
18717      &           17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy  -',
18718      &           ' proton   (GeV) ',2E14.4,/,17X,'- neutron  (GeV)'
18719      &          ,1X,2E14.4,/,1X,'Fermi-potential - proton   (GeV)',
18720      &           1X,2E14.4,/,17X,'- neutron  (GeV) ',2E14.4,/,/,
18721      &           1X,'Scale factor for Fermi-momentum    ',F4.2,/,
18722      &           /,1X,'Coulomb-energy ',2(E14.4,' GeV  '),/,/)
18723          LSTART = .FALSE.
18724       ENDIF
18725
18726       RETURN
18727       END
18728
18729 *$ CREATE DT_RESNCL.FOR
18730 *COPY DT_RESNCL
18731 *
18732 *===resncl=============================================================*
18733 *
18734       SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
18735
18736 ************************************************************************
18737 * Treatment of residual nuclei and nuclear effects.                    *
18738 *         MODE = 1     initializations                                 *
18739 *              = 2     treatment of final state                        *
18740 * This version dated 16.11.95 is written by S. Roesler.                *
18741 *                                                                      *
18742 * Last change 05.01.2007 by S. Roesler.                                *
18743 ************************************************************************
18744
18745       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18746       SAVE
18747
18748       PARAMETER ( LINP = 10 ,
18749      &            LOUT = 6 ,
18750      &            LDAT = 9 )
18751
18752       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
18753      &           TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
18754      &           ONETHI=ONE/THREE)
18755       PARAMETER (AMUAMU = 0.93149432D0,
18756      &           FM2MM  = 1.0D-12,
18757      &           RNUCLE = 1.12D0)
18758       PARAMETER ( EMVGEV = 1.0                D-03 )
18759       PARAMETER ( AMUGEV = 0.93149432         D+00 )
18760       PARAMETER ( AMPRTN = 0.93827231         D+00 )
18761       PARAMETER ( AMNTRN = 0.93956563         D+00 )
18762       PARAMETER ( AMELCT = 0.51099906         D-03 )
18763       PARAMETER ( HLFHLF = 0.5D+00 )
18764       PARAMETER ( FERTHO = 14.33       D-09 )
18765       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
18766       PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
18767       PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
18768
18769 * event history
18770
18771       PARAMETER (NMXHKK=200000)
18772
18773       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18774      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18775      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18776
18777 * extended event history
18778       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18779      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18780      &                IHIST(2,NMXHKK)
18781
18782 * particle properties (BAMJET index convention)
18783       CHARACTER*8  ANAME
18784       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18785      &                IICH(210),IIBAR(210),K1(210),K2(210)
18786
18787 * flags for input different options
18788       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18789       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18790      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18791
18792 * nuclear potential
18793       LOGICAL LFERMI
18794       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18795      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18796      &                ETACOU(2),ICOUL,LFERMI
18797
18798 * properties of interacting particles
18799       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18800
18801 * properties of photon/lepton projectiles
18802       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
18803
18804 * Lorentz-parameters of the current interaction
18805       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
18806      &                UMO,PPCM,EPROJ,PPROJ
18807
18808 * treatment of residual nuclei: wounded nucleons
18809       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18810
18811 * treatment of residual nuclei: 4-momenta
18812       LOGICAL LRCLPR,LRCLTA
18813       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18814      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18815
18816       DIMENSION PFSP(4),PSEC(4),PSEC0(4)
18817       DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
18818      &          IDXCOR(15000),IDXOTH(NMXHKK)
18819
18820       GOTO (1,2) MODE
18821
18822 *------- initializations
18823     1 CONTINUE
18824
18825 * initialize arrays for residual nuclei
18826       DO 10 K=1,5
18827          IF (K.LE.4) THEN
18828             PFSP(K)     = ZERO
18829          ENDIF
18830          PINIPR(K) = ZERO
18831          PINITA(K) = ZERO
18832          PRCLPR(K) = ZERO
18833          PRCLTA(K) = ZERO
18834          TRCLPR(K) = ZERO
18835          TRCLTA(K) = ZERO
18836    10 CONTINUE
18837       SCPOT = ONE
18838       NLOOP = 0
18839
18840 * correction of projectile 4-momentum for effective target pot.
18841 * and Coulomb-energy (in case of hadron-nucleus interaction only)
18842       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18843          EPNI = EPN
18844 *   Coulomb-energy:
18845 *     positively charged hadron - check energy for Coloumb pot.
18846          IF (IICH(IJPROJ).EQ.1) THEN
18847             THRESH = ETACOU(2)+AAM(IJPROJ)
18848             IF (EPNI.LE.THRESH) THEN
18849                WRITE(LOUT,1000)
18850  1000          FORMAT(/,1X,'KKINC:  WARNING!  projectile energy',
18851      &                ' below Coulomb threshold - event rejected',/)
18852                ISTHKK(1) = 1
18853                RETURN
18854             ENDIF
18855 *     negatively charged hadron - increase energy by Coulomb energy
18856          ELSEIF (IICH(IJPROJ).EQ.-1) THEN
18857             EPNI = EPNI+ETACOU(2)
18858          ENDIF
18859          IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
18860 *   Effective target potential
18861 *sr 6.6. binding energy only (to avoid negative exc. energies)
18862 C           EPNI = EPNI+EPOT(2,IJPROJ)
18863             EBIPOT = EBINDP(2)
18864             IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
18865      &         EBIPOT = EBINDN(2)
18866             EPNI = EPNI+ABS(EBIPOT)
18867 * re-initialization of DTLTRA
18868             DUM1 = ZERO
18869             DUM2 = ZERO
18870             CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
18871          ENDIF
18872       ENDIF
18873
18874 * projectile in n-n cms
18875       IF ((IP.LE.1).AND.(IT.GT.1)) THEN
18876          PMASS1 = AAM(IJPROJ)
18877 C* VDM assumption
18878 C         IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
18879          IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
18880          PMASS2 = AAM(1)
18881          PM1 = SIGN(PMASS1**2,PMASS1)
18882          PM2 = SIGN(PMASS2**2,PMASS2)
18883          PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
18884          PINIPR(5) = PMASS1
18885          IF (PMASS1.GT.ZERO) THEN
18886             PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
18887      &                      *(PINIPR(4)+PINIPR(5)))
18888          ELSE
18889             PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
18890          ENDIF
18891          AIT  = DBLE(IT)
18892          AITZ = DBLE(ITZ)
18893
18894 C        PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18895          PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18896
18897          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18898       ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
18899          PMASS1 = AAM(1)
18900          PMASS2 = AAM(IJTARG)
18901          PM1 = SIGN(PMASS1**2,PMASS1)
18902          PM2 = SIGN(PMASS2**2,PMASS2)
18903          PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
18904          PINITA(5) = PMASS2
18905          PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18906      &                    *(PINITA(4)+PINITA(5)))
18907          AIP  = DBLE(IP)
18908          AIPZ = DBLE(IPZ)
18909
18910 C        PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18911          PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18912
18913          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18914       ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18915          AIP  = DBLE(IP)
18916          AIPZ = DBLE(IPZ)
18917
18918 C        PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18919          PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18920
18921          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18922          AIT  = DBLE(IT)
18923          AITZ = DBLE(ITZ)
18924
18925 C        PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18926          PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18927
18928          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18929       ENDIF
18930
18931       RETURN
18932
18933 *------- treatment of final state
18934     2 CONTINUE
18935
18936       NLOOP = NLOOP+1
18937       IF (NLOOP.GT.1) SCPOT = 0.10D0
18938 C     WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18939
18940       JPW  = NPW
18941       JPCW = NPCW
18942       JTW  = NTW
18943       JTCW = NTCW
18944       DO 40 K=1,4
18945          PFSP(K)   = ZERO
18946    40 CONTINUE
18947
18948       NOB = 0
18949       NOM = 0
18950       DO 900 I=NPOINT(4),NHKK
18951          IDXOTH(I) = -1
18952          IF (ISTHKK(I).EQ.1) THEN
18953             IF (IDBAM(I).EQ.7) GOTO 900
18954             IPOT = 0
18955             IOTHER = 0
18956 * particle moving into forward direction
18957             IF (PHKK(3,I).GE.ZERO) THEN
18958 *   most likely to be effected by projectile potential
18959                IPOT = 1
18960 *     there is no projectile nucleus, try target
18961                IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18962                   IPOT   = 2
18963                   IF (IP.GT.1) IOTHER = 1
18964 *       there is no target nucleus --> skip
18965                   IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18966                ENDIF
18967 * particle moving into backward direction
18968             ELSE
18969 *   most likely to be effected by target potential
18970                IPOT = 2
18971 *     there is no target nucleus, try projectile
18972                IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18973                   IPOT   = 1
18974                   IF (IT.GT.1) IOTHER = 1
18975 *       there is no projectile nucleus --> skip
18976                   IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18977                ENDIF
18978             ENDIF
18979             IFLG = -IPOT
18980 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18981 *      =1: particle is not in overlap-region AND is inside target (2)
18982 *      =2: particle is not in overlap-region AND is inside projectile (1)
18983 * flag particles which are inside the nucleus ipot but not in its
18984 * overlap region
18985             IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18986             IF (IDBAM(I).NE.0) THEN
18987 * baryons: keep all nucleons and all others where flag is set
18988                IF (IIBAR(IDBAM(I)).NE.0) THEN
18989                   IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
18990      &                                                              THEN
18991                      NOB = NOB+1
18992                      PMOMB(NOB) = PHKK(3,I)
18993                      IDXB(NOB)  = SIGN(10000000*IABS(IFLG)
18994      &                           +1000000*IOTHER+I,IFLG)
18995                   ENDIF
18996 * mesons: keep only those mesons where flag is set
18997                ELSE
18998                   IF (IFLG.GT.0) THEN
18999                      NOM = NOM+1
19000                      PMOMM(NOM) = PHKK(3,I)
19001                      IDXM(NOM)  = 10000000*IFLG+1000000*IOTHER+I
19002                   ENDIF
19003                ENDIF
19004             ENDIF
19005          ENDIF
19006   900 CONTINUE
19007 *
19008 * sort particles in the arrays according to increasing long. momentum
19009       CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
19010       CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
19011 *
19012 * shuffle indices into one and the same array according to the later
19013 * sequence of correction
19014       NCOR = 0
19015       IF (IT.GT.1) THEN
19016          DO 910 I=1,NOB
19017             IF (PMOMB(I).GT.ZERO) GOTO 911
19018             NCOR = NCOR+1
19019             IDXCOR(NCOR) = IDXB(I)
19020   910    CONTINUE
19021   911    CONTINUE
19022          IF (IP.GT.1) THEN
19023             DO 912 J=1,NOB
19024                I = NOB+1-J
19025                IF (PMOMB(I).LT.ZERO) GOTO 913
19026                NCOR = NCOR+1
19027                IDXCOR(NCOR) = IDXB(I)
19028   912       CONTINUE
19029   913       CONTINUE
19030          ELSE
19031             DO 914 I=1,NOB
19032                IF (PMOMB(I).GT.ZERO) THEN
19033                   NCOR = NCOR+1
19034                   IDXCOR(NCOR) = IDXB(I)
19035                ENDIF
19036   914       CONTINUE
19037          ENDIF
19038       ELSE
19039          DO 915 J=1,NOB
19040             I = NOB+1-J
19041             NCOR = NCOR+1
19042             IDXCOR(NCOR) = IDXB(I)
19043   915    CONTINUE
19044       ENDIF
19045       DO 925 I=1,NOM
19046          IF (PMOMM(I).GT.ZERO) GOTO 926
19047          NCOR = NCOR+1
19048          IDXCOR(NCOR) = IDXM(I)
19049   925 CONTINUE
19050   926 CONTINUE
19051       DO 927 J=1,NOM
19052          I = NOM+1-J
19053          IF (PMOMM(I).LT.ZERO) GOTO 928
19054          NCOR = NCOR+1
19055          IDXCOR(NCOR) = IDXM(I)
19056   927 CONTINUE
19057   928 CONTINUE
19058 *
19059 C      IF (NEVHKK.EQ.484) THEN
19060 C         WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
19061 C 9000    FORMAT(1X,'wounded nucleons (proj.-p,n  targ.-p,n)',/,4I10)
19062 C         WRITE(LOUT,9001) NOB,NOM,NCOR
19063 C 9001    FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
19064 C         WRITE(LOUT,'(/,A)') ' baryons '
19065 C         DO 950 I=1,NOB
19066 CC           J     = IABS(IDXB(I))
19067 CC           INDEX = J-IABS(J/10000000)*10000000
19068 C            IPOT   = IABS(IDXB(I))/10000000
19069 C            IOTHER = IABS(IDXB(I))/1000000-IPOT*10
19070 C            INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
19071 C            WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
19072 C  950    CONTINUE
19073 C         WRITE(LOUT,'(/,A)') ' mesons '
19074 C         DO 951 I=1,NOM
19075 CC           INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
19076 C            IPOT   = IABS(IDXM(I))/10000000
19077 C            IOTHER = IABS(IDXM(I))/1000000-IPOT*10
19078 C            INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
19079 C            WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
19080 C  951    CONTINUE
19081 C 9002    FORMAT(1X,4I14,E14.5)
19082 C         WRITE(LOUT,'(/,A)') ' all '
19083 C         DO 952 I=1,NCOR
19084 CC           J     = IABS(IDXCOR(I))
19085 CC           INDEX = J-IABS(J/10000000)*10000000
19086 CC            IPOT   = IABS(IDXCOR(I))/10000000
19087 C            IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
19088 C            INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
19089 C            WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
19090 C  952    CONTINUE
19091 C 9003    FORMAT(1X,4I14)
19092 C      ENDIF
19093 *
19094       DO 20 ICOR=1,NCOR
19095          IPOT   = IABS(IDXCOR(ICOR))/10000000
19096          IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
19097          I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
19098          IDXOTH(I) = 1
19099
19100          IDSEC  = IDBAM(I)
19101
19102 * reduction of particle momentum by corresponding nuclear potential
19103 * (this applies only if Fermi-momenta are requested)
19104
19105          IF (LFERMI) THEN
19106
19107 *   Lorentz-transformation into the rest system of the selected nucleus
19108             IMODE = -IPOT-1
19109             CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19110      &                  PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
19111             PSECO  = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
19112             AMSEC  = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
19113             JPMOD  = 0
19114
19115             CHKLEV = TINY3
19116             IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
19117             IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
19118             IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
19119                IF (IOULEV(3).GT.0)
19120      &            WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
19121  2000          FORMAT(1X,'RESNCL: inconsistent mass of particle',
19122      &                ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
19123      &                I4,'   AMSEC: ',E12.3,'  AAM(IDSEC): ',E12.3,/)
19124                GOTO 23
19125             ENDIF
19126
19127             DO 21 K=1,4
19128                PSEC0(K) = PSEC(K)
19129    21       CONTINUE
19130
19131 *   the correction for nuclear potential effects is applied to as many
19132 *   p/n as many nucleons were wounded; the momenta of other final state
19133 *   particles are corrected only if they materialize inside the corresp.
19134 *   nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
19135 *   = 3 part. outside proj. and targ., >=10 in overlapping region)
19136             IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
19137                IF (IPOT.EQ.1) THEN
19138                   IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
19139 *      this is most likely a wounded nucleon
19140 **test
19141 C                    RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
19142 C    &                           +(VHKK(2,IPW(JPW))/FM2MM)**2
19143 C    &                           +(VHKK(3,IPW(JPW))/FM2MM)**2)
19144 C                    RAD   = RNUCLE*DBLE(IP)**ONETHI
19145 C                    FDEN  = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
19146 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19147 **
19148                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19149                      JPW = JPW-1
19150                      JPMOD = 1
19151                   ELSE
19152 *      correct only if part. was materialized inside nucleus
19153 *      and if it is ouside the overlapping region
19154                      IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
19155                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19156                         JPMOD = 1
19157                      ENDIF
19158                   ENDIF
19159                ELSEIF (IPOT.EQ.2) THEN
19160                   IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
19161 *      this is most likely a wounded nucleon
19162 **test
19163 C                    RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
19164 C    &                           +(VHKK(2,ITW(JTW))/FM2MM)**2
19165 C    &                           +(VHKK(3,ITW(JTW))/FM2MM)**2)
19166 C                    RAD   = RNUCLE*DBLE(IT)**ONETHI
19167 C                    FDEN  = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
19168 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19169 **
19170                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19171                      JTW = JTW-1
19172                      JPMOD = 1
19173                   ELSE
19174 *      correct only if part. was materialized inside nucleus
19175                      IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
19176                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19177                         JPMOD = 1
19178                      ENDIF
19179                   ENDIF
19180                ENDIF
19181             ELSE
19182                IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
19183                   PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19184                   JPMOD = 1
19185                ENDIF
19186             ENDIF
19187
19188             IF (NLOOP.EQ.1) THEN
19189 * Coulomb energy correction:
19190 * the treatment of Coulomb potential correction is similar to the
19191 * one for nuclear potential
19192                IF (IDSEC.EQ.1) THEN
19193                   IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
19194                      JPCW = JPCW-1
19195                   ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
19196                      JTCW = JTCW-1
19197                   ELSE
19198                      IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19199                   ENDIF
19200                ELSE
19201                   IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19202                ENDIF
19203                IF (IICH(IDSEC).EQ.1) THEN
19204 *    pos. particles: check if they are able to escape Coulomb potential
19205                   IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
19206                      ISTHKK(I) = 14+IPOT
19207                      IF (ISTHKK(I).EQ.15) THEN
19208                         DO 26 K=1,4
19209                            PHKK(K,I) = PSEC0(K)
19210                            TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19211    26                CONTINUE
19212                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19213                         IF (IDSEC.EQ.1) NPCW = NPCW-1
19214                      ELSEIF (ISTHKK(I).EQ.16) THEN
19215                         DO 27 K=1,4
19216                            PHKK(K,I) = PSEC0(K)
19217                            TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19218    27                   CONTINUE
19219                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19220                         IF (IDSEC.EQ.1) NTCW = NTCW-1
19221                      ENDIF
19222                      GOTO 20
19223                   ENDIF
19224                ELSEIF (IICH(IDSEC).EQ.-1) THEN
19225 *    neg. particles: decrease energy by Coulomb-potential
19226                   PSEC(4) = PSEC(4)-ETACOU(IPOT)
19227                   JPMOD = 1
19228                ENDIF
19229             ENDIF
19230
19231    25       CONTINUE
19232
19233             IF (PSEC(4).LT.AMSEC) THEN
19234                IF (IOULEV(6).GT.0)
19235      &            WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
19236  2001          FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
19237      &                ' is not allowed to escape nucleus',/,
19238      &                8X,'id : ',I3,'   reduced energy: ',E15.4,
19239      &                '   mass: ',E12.3)
19240                ISTHKK(I) = 14+IPOT
19241                IF (ISTHKK(I).EQ.15) THEN
19242                   DO 28 K=1,4
19243                      PHKK(K,I) = PSEC0(K)
19244                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19245    28             CONTINUE
19246                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19247                   IF (IDSEC.EQ.1) NPCW = NPCW-1
19248                ELSEIF (ISTHKK(I).EQ.16) THEN
19249                   DO 29 K=1,4
19250                      PHKK(K,I) = PSEC0(K)
19251                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19252    29             CONTINUE
19253                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19254                   IF (IDSEC.EQ.1) NTCW = NTCW-1
19255                ENDIF
19256                GOTO 20
19257             ENDIF
19258
19259             IF (JPMOD.EQ.1) THEN
19260                PSECN  = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
19261 * 4-momentum after correction for nuclear potential
19262                DO 22 K=1,3
19263                   PSEC(K) = PSEC(K)*PSECN/PSECO
19264    22          CONTINUE
19265
19266 * store recoil momentum from particles escaping the nuclear potentials
19267                DO 30 K=1,4
19268                   IF (IPOT.EQ.1) THEN
19269                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
19270                   ELSEIF (IPOT.EQ.2) THEN
19271                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
19272                   ENDIF
19273    30          CONTINUE
19274
19275 * transform momentum back into n-n cms
19276                IMODE = IPOT+1
19277                CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
19278      &                     PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19279      &                     IDSEC,IMODE)
19280             ENDIF
19281
19282          ENDIF
19283
19284    23    CONTINUE
19285          DO 31 K=1,4
19286             PFSP(K) = PFSP(K)+PHKK(K,I)
19287    31    CONTINUE
19288
19289    20 CONTINUE
19290
19291       DO 33 I=NPOINT(4),NHKK
19292          IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
19293             PFSP(1) = PFSP(1)+PHKK(1,I)
19294             PFSP(2) = PFSP(2)+PHKK(2,I)
19295             PFSP(3) = PFSP(3)+PHKK(3,I)
19296             PFSP(4) = PFSP(4)+PHKK(4,I)
19297          ENDIF
19298    33 CONTINUE
19299
19300       DO 34 K=1,5
19301          PRCLPR(K) = TRCLPR(K)
19302          PRCLTA(K) = TRCLTA(K)
19303    34 CONTINUE
19304
19305       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
19306 * hadron-nucleus interactions: get residual momentum from energy-
19307 * momentum conservation
19308          DO 32 K=1,4
19309             PRCLPR(K) = ZERO
19310             PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
19311    32    CONTINUE
19312       ELSE
19313 * nucleus-hadron, nucleus-nucleus: get residual momentum from
19314 * accumulated recoil momenta of particles leaving the spectators
19315 *   transform accumulated recoil momenta of residual nuclei into
19316 *   n-n cms
19317          PZI = PRCLPR(3)
19318          PEI = PRCLPR(4)
19319          CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
19320          PZI = PRCLTA(3)
19321          PEI = PRCLTA(4)
19322          CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
19323 C        IF (IP.GT.1) THEN
19324             PRCLPR(3) = PRCLPR(3)+PINIPR(3)
19325             PRCLPR(4) = PRCLPR(4)+PINIPR(4)
19326 C        ENDIF
19327          IF (IT.GT.1) THEN
19328             PRCLTA(3) = PRCLTA(3)+PINITA(3)
19329             PRCLTA(4) = PRCLTA(4)+PINITA(4)
19330          ENDIF
19331       ENDIF
19332
19333 * check momenta of residual nuclei
19334       IF (LEMCCK) THEN
19335          CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
19336      &               1,IDUM,IDUM)
19337          CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
19338      &               2,IDUM,IDUM)
19339          CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
19340      &               2,IDUM,IDUM)
19341          CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
19342      &               2,IDUM,IDUM)
19343          CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
19344 **sr 19.12. changed to avoid output when used with phojet
19345 C        CHKLEV = TINY3
19346          CHKLEV = TINY1
19347          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
19348 C        IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
19349 C    &      CALL DT_EVTOUT(4)
19350          IF (IREJ1.GT.0) RETURN
19351       ENDIF
19352
19353       RETURN
19354       END
19355
19356 *$ CREATE DT_SCN4BA.FOR
19357 *COPY DT_SCN4BA
19358 *
19359 *===scn4ba=============================================================*
19360 *
19361       SUBROUTINE DT_SCN4BA
19362
19363 ************************************************************************
19364 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot.    *
19365 * This version dated 12.12.95 is written by S. Roesler.                *
19366 ************************************************************************
19367
19368       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19369       SAVE
19370
19371       PARAMETER ( LINP = 10 ,
19372      &            LOUT = 6 ,
19373      &            LDAT = 9 )
19374
19375       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
19376      &           TINY10=1.0D-10)
19377
19378 * event history
19379
19380       PARAMETER (NMXHKK=200000)
19381
19382       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19383      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19384      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19385
19386 * extended event history
19387       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19388      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19389      &                IHIST(2,NMXHKK)
19390
19391 * particle properties (BAMJET index convention)
19392       CHARACTER*8  ANAME
19393       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19394      &                IICH(210),IIBAR(210),K1(210),K2(210)
19395
19396 * properties of interacting particles
19397       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
19398
19399 * nuclear potential
19400       LOGICAL LFERMI
19401       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
19402      &                EBINDP(2),EBINDN(2),EPOT(2,210),
19403      &                ETACOU(2),ICOUL,LFERMI
19404
19405 * treatment of residual nuclei: wounded nucleons
19406       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
19407
19408 * treatment of residual nuclei: 4-momenta
19409       LOGICAL LRCLPR,LRCLTA
19410       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19411      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19412
19413       DIMENSION PLAB(2,5),PCMS(4)
19414
19415       IREJ = 0
19416
19417 * get number of wounded nucleons
19418       NPW    = 0
19419       NPW0   = 0
19420       NPCW   = 0
19421       NPSTCK = 0
19422       NTW    = 0
19423       NTW0   = 0
19424       NTCW   = 0
19425       NTSTCK = 0
19426
19427       ISGLPR = 0
19428       ISGLTA = 0
19429       LRCLPR = .FALSE.
19430       LRCLTA = .FALSE.
19431
19432 C     DO 2 I=1,NHKK
19433       DO 2 I=1,NPOINT(1)
19434 * projectile nucleons wounded in primary interaction and in fzc
19435          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
19436             NPW      = NPW+1
19437             IPW(NPW) = I
19438             NPSTCK   = NPSTCK+1
19439             IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
19440             IF (ISTHKK(I).EQ.11)  NPW0 = NPW0+1
19441 C           IF (IP.GT.1) THEN
19442                DO 5 K=1,4
19443                   TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
19444     5          CONTINUE
19445 C           ENDIF
19446 * target nucleons wounded in primary interaction and in fzc
19447          ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
19448             NTW      = NTW+1
19449             ITW(NTW) = I
19450             NTSTCK   = NTSTCK+1
19451             IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
19452             IF (ISTHKK(I).EQ.12)  NTW0 = NTW0+1
19453             IF (IT.GT.1) THEN
19454                DO 6 K=1,4
19455                   TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
19456     6          CONTINUE
19457             ENDIF
19458          ELSEIF (ISTHKK(I).EQ.13) THEN
19459             ISGLPR = I
19460          ELSEIF (ISTHKK(I).EQ.14) THEN
19461             ISGLTA = I
19462          ENDIF
19463     2 CONTINUE
19464
19465       DO 11 I=NPOINT(4),NHKK
19466 * baryons which are unable to escape the nuclear potential of proj.
19467          IF (ISTHKK(I).EQ.15) THEN
19468             ISGLPR = I
19469             NPSTCK = NPSTCK-1
19470             IF (IIBAR(IDBAM(I)).NE.0) THEN
19471                NPW    = NPW-1
19472                IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
19473             ENDIF
19474             DO 7 K=1,4
19475                TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19476     7       CONTINUE
19477 * baryons which are unable to escape the nuclear potential of targ.
19478          ELSEIF (ISTHKK(I).EQ.16) THEN
19479             ISGLTA = I
19480             NTSTCK = NTSTCK-1
19481             IF (IIBAR(IDBAM(I)).NE.0) THEN
19482                NTW    = NTW-1
19483                IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
19484             ENDIF
19485             DO 8 K=1,4
19486                TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19487     8       CONTINUE
19488          ENDIF
19489    11 CONTINUE
19490
19491 * residual nuclei so far
19492       IRESP = IP-NPSTCK
19493       IREST = IT-NTSTCK
19494
19495 * ckeck for "residual nuclei" consisting of one nucleon only
19496 * treat it as final state particle
19497       IF (IRESP.EQ.1) THEN
19498          ID  = IDBAM(ISGLPR)
19499          IST = ISTHKK(ISGLPR)
19500          CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
19501      &               PHKK(3,ISGLPR),PHKK(4,ISGLPR),
19502      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
19503          IF (IST.EQ.13) THEN
19504             ISTHKK(ISGLPR) = 11
19505          ELSE
19506             ISTHKK(ISGLPR) = 2
19507          ENDIF
19508          CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
19509      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19510      &               IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
19511          NOBAM(NHKK)      = NOBAM(ISGLPR)
19512          JDAHKK(1,ISGLPR) = NHKK
19513          DO 21 K=1,4
19514             TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
19515    21    CONTINUE
19516       ENDIF
19517       IF (IREST.EQ.1) THEN
19518          ID  = IDBAM(ISGLTA)
19519          IST = ISTHKK(ISGLTA)
19520          CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
19521      &               PHKK(3,ISGLTA),PHKK(4,ISGLTA),
19522      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
19523          IF (IST.EQ.14) THEN
19524             ISTHKK(ISGLTA) = 12
19525          ELSE
19526             ISTHKK(ISGLTA) = 2
19527          ENDIF
19528          CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
19529      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19530      &               IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
19531          NOBAM(NHKK)      = NOBAM(ISGLTA)
19532          JDAHKK(1,ISGLTA) = NHKK
19533          DO 22 K=1,4
19534             TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
19535    22    CONTINUE
19536       ENDIF
19537
19538 * get nuclear potential corresp. to the residual nucleus
19539       IPRCL  = IP -NPW
19540       IPZRCL = IPZ-NPCW
19541       ITRCL  = IT -NTW
19542       ITZRCL = ITZ-NTCW
19543       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
19544
19545 * baryons unable to escape the nuclear potential are treated as
19546 * excited nucleons (ISTHKK=15,16)
19547       DO 3 I=NPOINT(4),NHKK
19548          IF (ISTHKK(I).EQ.1) THEN
19549             ID  = IDBAM(I)
19550             IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
19551 *   final state n and p not being outside of both nuclei are considered
19552                NPOTP = 1
19553                NPOTT = 1
19554                IF ( (IP.GT.1)      .AND.(IRESP.GT.1).AND.
19555      &              (NOBAM(I).NE.1).AND.(NPW.GT.0)        ) THEN
19556 *     Lorentz-trsf. into proj. rest sys. for those being inside proj.
19557                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19558      &                        PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
19559      &                        PLAB(1,4),ID,-2)
19560                   PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
19561                   PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
19562      &                                  (PLAB(1,4)+PLABT) ))
19563                   EKIN = PLAB(1,4)-PLAB(1,5)
19564                   IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
19565                   IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
19566                ENDIF
19567                IF ( (IT.GT.1)      .AND.(IREST.GT.1).AND.
19568      &              (NOBAM(I).NE.2).AND.(NTW.GT.0)        ) THEN
19569 *     Lorentz-trsf. into targ. rest sys. for those being inside targ.
19570                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19571      &                        PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
19572      &                        PLAB(2,4),ID,-3)
19573                   PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
19574                   PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
19575      &                                  (PLAB(2,4)+PLABT) ))
19576                   EKIN = PLAB(2,4)-PLAB(2,5)
19577                   IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
19578                   IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
19579                ENDIF
19580                IF (PHKK(3,I).GE.ZERO) THEN
19581                   ISTHKK(I) = NPOTT
19582                   IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
19583                ELSE
19584                   ISTHKK(I) = NPOTP
19585                   IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
19586                ENDIF
19587                IF (ISTHKK(I).NE.1) THEN
19588                   J = ISTHKK(I)-14
19589                   DO 4 K=1,5
19590                      PHKK(K,I) = PLAB(J,K)
19591     4             CONTINUE
19592                   IF (ISTHKK(I).EQ.15) THEN
19593                      NPW = NPW-1
19594                      IF (ID.EQ.1) NPCW = NPCW-1
19595                      DO 9 K=1,4
19596                         TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19597     9                CONTINUE
19598                   ELSEIF (ISTHKK(I).EQ.16) THEN
19599                      NTW = NTW-1
19600                      IF (ID.EQ.1) NTCW = NTCW-1
19601                      DO 10 K=1,4
19602                         TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19603    10                CONTINUE
19604                   ENDIF
19605                ENDIF
19606             ENDIF
19607          ENDIF
19608     3 CONTINUE
19609
19610 * again: get nuclear potential corresp. to the residual nucleus
19611       IPRCL  = IP -NPW
19612       IPZRCL = IPZ-NPCW
19613       ITRCL  = IT -NTW
19614       ITZRCL = ITZ-NTCW
19615 c      AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
19616 cC     AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
19617 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
19618 C     AFERP = 0.0D0
19619 c      AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
19620 cC     AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
19621 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
19622 C     AFERT = 0.0D0
19623 C     IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
19624 C     IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
19625 C     IF (AFERP.GT.0.85D0) AFERP = 0.85D0
19626 C     IF (AFERT.GT.0.85D0) AFERT = 0.85D0
19627       AFERP = FERMOD+0.1D0
19628       AFERT = FERMOD+0.1D0
19629
19630       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
19631
19632       RETURN
19633       END
19634
19635 *$ CREATE DT_FICONF.FOR
19636 *COPY DT_FICONF
19637 *
19638 *===ficonf=============================================================*
19639 *
19640       SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
19641
19642 ************************************************************************
19643 * Treatment of FInal CONFiguration including evaporation, fission and  *
19644 * Fermi-break-up (for light nuclei only).                              *
19645 * Adopted from the original routine FINALE and extended to residual    *
19646 * projectile nuclei.                                                   *
19647 * This version dated 12.12.95 is written by S. Roesler.                *
19648 *                                                                      *
19649 * Last change 27.12.2006 by S. Roesler.                                *
19650 ************************************************************************
19651
19652       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19653       SAVE
19654
19655       PARAMETER ( LINP = 10 ,
19656      &            LOUT = 6 ,
19657      &            LDAT = 9 )
19658
19659       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
19660       PARAMETER (ANGLGB=5.0D-16)
19661
19662 * event history
19663
19664       PARAMETER (NMXHKK=200000)
19665
19666       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19667      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19668      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19669
19670 * extended event history
19671       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19672      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19673      &                IHIST(2,NMXHKK)
19674
19675 * rejection counter
19676       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
19677      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
19678      &                IREXCI(3),IRDIFF(2),IRINC
19679
19680 * central particle production, impact parameter biasing
19681       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
19682
19683 * particle properties (BAMJET index convention)
19684       CHARACTER*8  ANAME
19685       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19686      &                IICH(210),IIBAR(210),K1(210),K2(210)
19687
19688 * treatment of residual nuclei: 4-momenta
19689       LOGICAL LRCLPR,LRCLTA
19690       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19691      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19692
19693 * treatment of residual nuclei: properties of residual nuclei
19694       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19695      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19696      &                NTOTFI(2),NPROFI(2)
19697
19698 * statistics: residual nuclei
19699       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19700      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19701      &                NINCST(2,4),NINCEV(2),
19702      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19703      &                NRESPB(2),NRESCH(2),NRESEV(4),
19704      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19705      &                NEVAFI(2,2)
19706
19707 * flags for input different options
19708       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19709       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19710      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19711
19712 *      INCLUDE '(DIMPAR)'
19713 *     DIMPAR taken from FLUKA
19714       PARAMETER ( MXXRGN =20000 )
19715       PARAMETER ( MXXMDF =  710 )
19716       PARAMETER ( MXXMDE =  702 )
19717       PARAMETER ( MFSTCK =40000 )
19718       PARAMETER ( MESTCK =  100 )
19719       PARAMETER ( MOSTCK = 2000 )
19720       PARAMETER ( MXPRSN =  100 )
19721       PARAMETER ( MXPDPM =  800 )
19722       PARAMETER ( MXPSCS =30000 )
19723       PARAMETER ( MXGLWN =  300 )
19724       PARAMETER ( MXOUTU =   50 )
19725       PARAMETER ( NALLWP =   64 )
19726       PARAMETER ( NELEMX =   80 )
19727       PARAMETER ( MPDPDX =   18 )
19728       PARAMETER ( MXHTTR =  260 )
19729       PARAMETER ( MXSEAX =   20 )
19730       PARAMETER ( MXHTNC = MXSEAX + 1 )
19731       PARAMETER ( ICOMAX = 2400 )
19732       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
19733       PARAMETER ( NSTBIS =  304 )
19734       PARAMETER ( NQSTIS =   46 )
19735       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
19736       PARAMETER ( MXPABL =  120 )
19737       PARAMETER ( IDMAXP =  450 )
19738       PARAMETER ( IDMXDC = 2000 )
19739       PARAMETER ( MXMCIN =  410 )
19740       PARAMETER ( IHYPMX =    4 )
19741       PARAMETER ( MKBMX1 =   11 )
19742       PARAMETER ( MKBMX2 =   11 )
19743       PARAMETER ( MXIRRD = 2500 )
19744       PARAMETER ( MXTRDC = 1500 )
19745       PARAMETER ( NKTL   =   17 )
19746       PARAMETER ( NBLNMX = 40000000 )
19747
19748 *      INCLUDE '(GENSTK)'
19749 *     GENSTK taken from FLUKA
19750       COMMON / GENSTK /                CXR    (MXPSCS), CYR    (MXPSCS),
19751      &                CZR    (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
19752      &                CZRPOL (MXPSCS), TKI    (MXPSCS), PLR    (MXPSCS),
19753      &                WEI    (MXPSCS), AGESEC (MXPSCS), TV    , TVCMS  ,
19754      &                TVRECL,  TVHEAV, TVBIND,
19755      &                KPART  (MXPSCS), INFEXT (MXPSCS), NP0   , NP
19756
19757 *      INCLUDE '(RESNUC)'
19758 *     RESNUC from FLUKA
19759       LOGICAL LRNFSS, LFRAGM
19760       COMMON /RESNUC/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19761      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19762      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
19763      &                  PYRES,  PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
19764      &                 ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
19765      &                  KTARP,  KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
19766      &                 IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,  ICRES,
19767      &                  IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
19768      &                 IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
19769      &                 IEV4HE, IDEEXG,  IBTAR, ICHTAR, IBLEFT, ICLEFT,
19770      &                 ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
19771      &                 LRNFSS, LFRAGM
19772
19773       PARAMETER ( EMVGEV = 1.0                D-03 )
19774       PARAMETER ( AMUGEV = 0.93149432         D+00 )
19775       PARAMETER ( AMPRTN = 0.93827231         D+00 )
19776       PARAMETER ( AMNTRN = 0.93956563         D+00 )
19777       PARAMETER ( AMELCT = 0.51099906         D-03 )
19778       PARAMETER ( ELCCGS = 4.8032068          D-10 )
19779       PARAMETER ( ELCMKS = 1.60217733         D-19 )
19780       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19781      &                   * 1.D-09 )
19782       PARAMETER ( HLFHLF = 0.5D+00 )
19783       PARAMETER ( FERTHO = 14.33       D-09 )
19784       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
19785       PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
19786       PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
19787
19788 *      INCLUDE '(NUCDAT)'
19789 *     Taken from FLUKA
19790       PARAMETER ( AMUAMU = AMUGEV )
19791       PARAMETER ( AMPROT = AMPRTN )
19792       PARAMETER ( AMNEUT = AMNTRN )
19793       PARAMETER ( AMELEC = AMELCT )
19794       PARAMETER ( R0NUCL = 1.12        D+00 )
19795       PARAMETER ( RCCOUL = 1.7         D+00 )
19796       PARAMETER ( COULPR = COUGFM )
19797       PARAMETER ( AMHYDR = AMPRTN + AMELCT  )
19798       PARAMETER ( AMHTON = AMHYDR - AMNTRN  )
19799       PARAMETER ( AMNTOU = AMNTRN - AMUC12  )
19800       PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
19801       PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
19802 *   Gammin : threshold for deexcitation gammas production, set to 1 keV
19803 *   (this means that up to 1 keV of energy unbalancing can occur
19804 *    during an event)
19805       PARAMETER ( GAMMIN = 1.0D-06 )
19806       PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
19807 *   Tvepsi : "epsilon" for excitation energy, set to gammin / 100
19808       PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
19809 *
19810       COMMON /NUCDAT/ AV0WEL,     APFRMX,     AEFRMX,     AEFRMA,
19811      &                RDSNUC,     V0WELL (2), PFRMMX (2), EFRMMX (2),
19812      &                EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
19813      &                VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
19814      &                PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
19815      &                EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
19816      &                ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV    ,
19817      &                AMRCSQ    , ATO1O3    , ZTO1O3    , FRMRFC    ,
19818      &                ELBNDE (0:110)
19819
19820 *      INCLUDE '(PAREVT)'
19821 *     Taken from FLUKA
19822       PARAMETER ( FRDIFF = 0.2D+00 )
19823       PARAMETER ( ETHSEA = 1.0D+00 )
19824 *
19825       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
19826      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
19827      &        LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
19828      &        LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
19829       COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
19830      &                  LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
19831      &                  LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
19832      &                  LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
19833      &                  LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
19834      &                  LVP2XX, LV2XNW, LNWV2X, LEVFIN
19835
19836 *      INCLUDE '(FHEAVY)'
19837 *     Taken from FLUKA
19838       PARAMETER ( MXHEAV = 100 )
19839       PARAMETER ( KXHEAV =  30 )
19840       CHARACTER*8 ANHEAV
19841       COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19842      &                  CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19843      &                  PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19844      &                  AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
19845      &                  AMHEAV (KXHEAV), AMNHEA (KXHEAV),
19846      &                  KHEAVY (MXHEAV), INFHEA (MXHEAV),
19847      &                  ICHEAV (KXHEAV), IBHEAV (KXHEAV),
19848      &                  IMHEAV (KXHEAV), IHHEAV (KXHEAV),
19849      &                  KHHEAV (IHYPMX,KXHEAV), NPHEAV
19850       COMMON / FHEAVC / ANHEAV (KXHEAV)
19851
19852 * event flag
19853       COMMON /DTEVNO/ NEVENT,ICASCA
19854
19855       DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
19856      &          PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
19857      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
19858
19859       DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
19860       LOGICAL LLCPOT
19861       DATA EXC,NEXC /520*ZERO,520*0/
19862       DATA EXPNUC /4.0D-3,4.0D-3/
19863
19864       IREJ   = 0
19865       LRCLPR = .FALSE.
19866       LRCLTA = .FALSE.
19867
19868 * skip residual nucleus treatment if not requested or in case
19869 * of central collisions
19870       IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
19871
19872       DO 1 K=1,2
19873          IDPAR(K) = 0
19874          IDXPAR(K)= 0
19875          NTOT(K)  = 0
19876          NTOTFI(K)= 0
19877          NPRO(K)  = 0
19878          NPROFI(K)= 0
19879          NN(K)    = 0
19880          NH(K)    = 0
19881          NHPOS(K) = 0
19882          NQ(K)    = 0
19883          EEXC(K)  = ZERO
19884          MO1(K)   = 0
19885          MO2(K)   = 0
19886          DO 2 I=1,4
19887             VRCL(K,I) = ZERO
19888             WRCL(K,I) = ZERO
19889     2    CONTINUE
19890     1 CONTINUE
19891       NFSP = 0
19892       INUC(1) = IP
19893       INUC(2) = IT
19894
19895       DO 3 I=1,NHKK
19896
19897 * number of final state particles
19898          IF (ABS(ISTHKK(I)).EQ.1) THEN
19899             NFSP  = NFSP+1
19900             IDFSP = IDBAM(I)
19901          ENDIF
19902
19903 * properties of remaining nucleon configurations
19904          KF = 0
19905          IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
19906          IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
19907          IF (KF.GT.0) THEN
19908             IF (MO1(KF).EQ.0) MO1(KF) = I
19909             MO2(KF)  = I
19910 *   position of residual nucleus = average position of nucleons
19911             DO 4 K=1,4
19912                VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
19913                WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
19914     4       CONTINUE
19915 *   total number of particles contributing to each residual nucleus
19916             NTOT(KF)  = NTOT(KF)+1
19917             IDTMP     = IDBAM(I)
19918             IDXTMP    = I
19919 *   total charge of residual nuclei
19920             NQ(KF) = NQ(KF)+IICH(IDTMP)
19921 *   number of protons
19922             IF (IDHKK(I).EQ.2212) THEN
19923                NPRO(KF) = NPRO(KF)+1
19924 *   number of neutrons
19925             ELSEIF (IDHKK(I).EQ.2112) THEN
19926                NN(KF) = NN(KF)+1
19927             ELSE
19928 *   number of baryons other than n, p
19929                IF (IIBAR(IDTMP).EQ.1) THEN
19930                   NH(KF) = NH(KF)+1
19931                   IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
19932                ELSE
19933 *   any other mesons (status set to 1)
19934 C                 WRITE(LOUT,1002) KF,IDTMP
19935 C1002             FORMAT(1X,'FICONF:   residual nucleus ',I2,
19936 C    &                   ' containing meson ',I4,', status set to 1')
19937                   ISTHKK(I) = 1
19938                   IDTMP     = IDPAR(KF)
19939                   IDXTMP    = IDXPAR(KF)
19940                   NTOT(KF)  = NTOT(KF)-1
19941                ENDIF
19942             ENDIF
19943             IDPAR(KF)  = IDTMP
19944             IDXPAR(KF) = IDXTMP
19945          ENDIF
19946     3 CONTINUE
19947
19948 * reject elastic events (def: one final state particle = projectile)
19949       IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
19950          IREXCI(3) = IREXCI(3)+1
19951          GOTO 9999
19952 C        RETURN
19953       ENDIF
19954
19955 * check if one nucleus disappeared..
19956 C     IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
19957 C        DO 5 K=1,4
19958 C           PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
19959 C           PRCLPR(K) = ZERO
19960 C   5    CONTINUE
19961 C     ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
19962 C        DO 6 K=1,4
19963 C           PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
19964 C           PRCLTA(K) = ZERO
19965 C   6    CONTINUE
19966 C     ENDIF
19967
19968       ICOR   = 0
19969       INORCL = 0
19970       DO 7 I=1,2
19971          DO 8 K=1,4
19972 * get the average of the nucleon positions
19973             VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
19974             WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
19975             IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
19976             IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
19977     8    CONTINUE
19978 * mass number and charge of residual nuclei
19979          AIF(I)  = DBLE(NTOT(I))
19980          AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
19981          IF (NTOT(I).GT.1) THEN
19982 * masses of residual nuclei in ground state
19983
19984 C           AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I))
19985             AMRCL0(I) = AIF(I)*AMUC12
19986      &                  +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM)
19987
19988 * masses of residual nuclei
19989             PTORCL   = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
19990             AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
19991             IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
19992 *
19993 *   M_res^2 < 0 : configuration not allowed
19994 *
19995 *      a) re-calculate E_exc with scaled nuclear potential
19996 *         (conditional jump to label 9998)
19997 *      b) or reject event if N_loop(max) is exceeded
19998 *         (conditional jump to label 9999)
19999 *
20000             IF (AMRCL(I).LE.ZERO) THEN
20001                IF (IOULEV(3).GT.0)
20002      &            WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
20003      &                             PRCL(I,4),NTOT
20004  1000          FORMAT(1X,'warning! negative excitation energy',/,
20005      &                I4,4E15.4,2I4)
20006                AMRCL(I) = ZERO
20007                EEXC(I)  = ZERO
20008                IF (NLOOP.LE.500) THEN
20009                   GOTO 9998
20010                ELSE
20011                   IREXCI(2) = IREXCI(2)+1
20012                   GOTO 9999
20013                ENDIF
20014 *
20015 *   0 < M_res < M_res0 : mass below ground-state mass
20016 *
20017 *      a) we had residual nuclei with mass N_tot and reasonable E_exc
20018 *         before- assign average E_exc of those configurations to this
20019 *         one ( Nexc(i,N_tot) > 0 )
20020 *      b) or (and this applies always if run in transport codes) go up
20021 *         one mass number and
20022 *           i) if mass now larger than proj/targ mass or if run in
20023 *              transport codes assign average E_exc per wounded nucleon
20024 *              x number of wounded nucleons (Inuc-Ntot)
20025 *          ii) or assign average E_exc of those configurations to this
20026 *              one ( Nexc(i,m) > 0 )
20027 *
20028             ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
20029      &                                                         THEN
20030                M = MIN(NTOT(I),260)
20031                IF (NEXC(I,M).GT.0) THEN
20032                   AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20033                ELSE
20034    70             CONTINUE
20035                   M = M+1
20036 **sr corrected 27.12.06
20037 *                 IF (M.GE.INUC(I)) THEN
20038 *                    AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
20039                   IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
20040                      IF ( INUC (I) .GT. NTOT (I) ) THEN
20041                         AMRCL(I) = AMRCL0(I)
20042      &                         + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
20043                      ELSE
20044                         AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
20045                      END IF
20046 **
20047                   ELSE
20048                      IF (NEXC(I,M).GT.0) THEN
20049                         AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20050                      ELSE
20051                         GOTO 70
20052                      ENDIF
20053                   ENDIF
20054                ENDIF
20055                EEXC(I)  = AMRCL(I)-AMRCL0(I)
20056                ICOR     = ICOR+I
20057 *
20058 *   M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
20059 *
20060 *      a) re-calculate E_exc with scaled nuclear potential
20061 *         (conditional jump to label 9998)
20062 *      b) or reject event if N_loop(max) is exceeded
20063 *         (conditional jump to label 9999)
20064 *
20065 *
20066             ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
20067                IF (IOULEV(3).GT.0)
20068      &            WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
20069  1004          FORMAT(1X,'warning! too high excitation energy',/,
20070      &                I4,1P,2E15.4,3I5)
20071                AMRCL(I) = ZERO
20072                EEXC(I)  = ZERO
20073                IF (NLOOP.LE.500) THEN
20074                   GOTO 9998
20075                ELSE
20076                   IREXCI(2) = IREXCI(2)+1
20077                   GOTO 9999
20078                ENDIF
20079 *
20080 *   Otherwise (reasonable E_exc) :
20081 *      E_exc = M_res - M_res0
20082 *      in addition: calculate and save E_exc per wounded nucleon as
20083 *                   well as E_exc in <E_exc> counter
20084 *
20085             ELSE
20086 * excitation energies of residual nuclei
20087                EEXC(I)   = AMRCL(I)-AMRCL0(I)
20088 **sr 27.12.06 new excitation energy correction by A.F.
20089 *
20090 * all parts with Ilcopt<3 commented since not used
20091 *
20092 * still to be done/decided:
20093 *   Increase Icor and put back both residual nuclei on mass shell
20094 *   with the exciting correction further below.
20095 *   For the moment the modification in the excitation energy is simply
20096 *   corrected by scaling the energy of the residual nucleus.
20097 *
20098                LLCPOT = .TRUE.
20099                ILCOPT = 3
20100                IF ( LLCPOT ) THEN
20101                   NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
20102                   IF ( ILCOPT .LE. 2 ) THEN
20103 C* Patch for Fermi momentum reduction correlated with impact parameter:
20104 C                     FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
20105 C                     DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
20106 C                     AKPRHO = ONE - DLKPRH
20107 C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
20108 C                     FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO  - ONE,
20109 C     &                              0.05D+00 )
20110 C*                    REDORI = 0.75D+00
20111 C*                    REDORI = ONE
20112 C                     REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20113                   ELSE
20114                      DLKPRH = ZERO
20115                      RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
20116 *  Take out roughly one/half of the skin:
20117                      RDCORE = RDCORE - 0.5D+00
20118                      FRCFLL = RDCORE**3
20119                      PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
20120                      PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
20121                      FRCFLL = ONE - PRSKIN
20122                      FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
20123                      REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20124                   END IF
20125                   IF ( NNCHIT .GT. 0 ) THEN
20126 C                     IF ( ILCOPT .EQ. 1 ) THEN
20127 C                        SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
20128 C                        DO 1220 NCH = 1, 10
20129 C                           ETAETA = ( ONE - SKINRH**INUC(I)
20130 C     &                            - DBLE(INUC(I))* ( ONE - FRCFLL )
20131 C     &                            * ( ONE - SKINRH ) )
20132 C     &                            / ( SKINRH**INUC(I) - DBLE (INUC(I))
20133 C     &                            * ( ONE - FRCFLL) * SKINRH )
20134 C                           SKINRH = SKINRH * ( ONE + ETAETA )
20135 C 1220                   CONTINUE
20136 C                        PRSKIN = SKINRH**(NNCHIT-1)
20137 C                     ELSE IF ( ILCOPT .EQ. 2 ) THEN
20138 C                        PRSKIN = ONE - FRCFLL
20139 C                     END IF
20140                      REDCTN = ZERO
20141                      DO 1230 NCH = 1, NNCHIT
20142                         IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
20143                            PRFRMI = (( ONE - 2.D+00 * DLKPRH )
20144      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
20145                         ELSE
20146                            PRFRMI = ( ONE - 2.D+00 * DLKPRH
20147      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
20148                         END IF
20149                         REDCTN = REDCTN + PRFRMI**2
20150  1230                CONTINUE
20151                      REDCTN = REDCTN / DBLE (NNCHIT)
20152                   ELSE
20153                      REDCTN = 0.5D+00
20154                   END IF
20155                   EEXC  (I) = EEXC   (I) * REDCTN / REDORI
20156                   AMRCL (I) = AMRCL0 (I) + EEXC (I)
20157                   PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
20158                END IF
20159 **
20160                IF (ICASCA.EQ.0) THEN
20161                   EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
20162                   M = MIN(NTOT(I),260)
20163                   EXC(I,M)  = EXC(I,M)+EEXC(I)
20164                   NEXC(I,M) = NEXC(I,M)+1
20165                ENDIF
20166             ENDIF
20167          ELSEIF (NTOT(I).EQ.1) THEN
20168             WRITE(LOUT,1003) I
20169  1003       FORMAT(1X,'FICONF:   warning! NTOT(I)=1? (I=',I3,')')
20170             GOTO 9999
20171          ELSE
20172             AMRCL0(I) = ZERO
20173             AMRCL(I)  = ZERO
20174             EEXC(I)   = ZERO
20175             INORCL    = INORCL+I
20176          ENDIF
20177     7 CONTINUE
20178
20179       PRCLPR(5) = AMRCL(1)
20180       PRCLTA(5) = AMRCL(2)
20181
20182       IF (ICOR.GT.0) THEN
20183          IF (INORCL.EQ.0) THEN
20184 * one or both residual nuclei consist of one nucleon only, transform
20185 * this nucleon on mass shell
20186             DO 9 K=1,4
20187                P1IN(K) = PRCL(1,K)
20188                P2IN(K) = PRCL(2,K)
20189     9       CONTINUE
20190             XM1 = AMRCL(1)
20191             XM2 = AMRCL(2)
20192             CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
20193             IF (IREJ1.GT.0) THEN
20194                WRITE(LOUT,*) 'ficonf-mashel rejection'
20195                GOTO 9999
20196             ENDIF
20197             DO 10 K=1,4
20198                PRCL(1,K) = P1OUT(K)
20199                PRCL(2,K) = P2OUT(K)
20200                PRCLPR(K) = P1OUT(K)
20201                PRCLTA(K) = P2OUT(K)
20202    10       CONTINUE
20203             PRCLPR(5) = AMRCL(1)
20204             PRCLTA(5) = AMRCL(2)
20205          ELSE
20206             IF (IOULEV(3).GT.0)
20207      &      WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
20208      &                       INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
20209      &                       AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
20210      &                       AMRCL(2),AMRCL(2)-AMRCL0(2)
20211  1001       FORMAT(1X,'FICONF:   warning! no residual nucleus for',
20212      &             ' correction',/,11X,'at event',I8,
20213      &             ',  nucleon config. 1:',2I4,' 2:',2I4,
20214      &             2(/,11X,3E12.3))
20215             IF (NLOOP.LE.500) THEN
20216                GOTO 9998
20217             ELSE
20218                IREXCI(1) = IREXCI(1)+1
20219             ENDIF
20220          ENDIF
20221       ENDIF
20222
20223 * update counter
20224 C     IF (NRESEV(1).NE.NEVHKK) THEN
20225 C        NRESEV(1) = NEVHKK
20226 C        NRESEV(2) = NRESEV(2)+1
20227 C     ENDIF
20228       NRESEV(2) = NRESEV(2)+1
20229       DO 15 I=1,2
20230          EXCDPM(I)   = EXCDPM(I)+EEXC(I)
20231          EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
20232          NRESTO(I) = NRESTO(I)+NTOT(I)
20233          NRESPR(I) = NRESPR(I)+NPRO(I)
20234          NRESNU(I) = NRESNU(I)+NN(I)
20235          NRESBA(I) = NRESBA(I)+NH(I)
20236          NRESPB(I) = NRESPB(I)+NHPOS(I)
20237          NRESCH(I) = NRESCH(I)+NQ(I)
20238    15 CONTINUE
20239
20240 * evaporation
20241       IF (LEVPRT) THEN
20242          DO 13 I=1,2
20243 * initialize evaporation counter
20244             EEXCFI(I) = ZERO
20245             IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
20246      &          (EEXC(I).GT.ZERO)) THEN
20247 * put residual nuclei into DTEVT1
20248                IDRCL = 80000
20249                JMASS = INT( AIF(I))
20250                JCHAR = INT(AIZF(I))
20251 *  the following patch is required to transmit the correct excitation
20252 *   energy to Eventd
20253                IF (ITRSPT.EQ.1) THEN
20254                   IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
20255      &                (IOULEV(3).GT.0))
20256      &               WRITE(LOUT,*)
20257      &                  ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
20258      &                              AMRCL(I),AMRCL0(I),EEXC(I)
20259                   PRCL0 = PRCL(I,4)
20260                   PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
20261      &                                                    +PRCL(I,3)**2)
20262                   IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
20263                      WRITE(LOUT,*)
20264      &                  ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
20265                   ENDIF
20266                ENDIF
20267                CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
20268      &              PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
20269 **sr 22.6.97
20270                NOBAM(NHKK) = I
20271 **
20272                DO 14 J=1,4
20273                   VHKK(J,NHKK) = VRCL(I,J)
20274                   WHKK(J,NHKK) = WRCL(I,J)
20275    14          CONTINUE
20276 *  interface to evaporation module - fill final residual nucleus into
20277 *  common FKRESN
20278 *   fill resnuc only if code is not used as event generator in Fluka
20279                IF (ITRSPT.NE.1) THEN
20280                   PXRES  = PRCL(I,1)
20281                   PYRES  = PRCL(I,2)
20282                   PZRES  = PRCL(I,3)
20283                   IBRES  = NPRO(I)+NN(I)+NH(I)
20284                   ICRES  = NPRO(I)+NHPOS(I)
20285                   ANOW   = DBLE(IBRES)
20286                   ZNOW   = DBLE(ICRES)
20287                   PTRES  = SQRT(PXRES**2+PYRES**2+PZRES**2)
20288 *   ground state mass of the residual nucleus (should be equal to AM0T)
20289
20290                   AMNRES = AMRCL0(I)
20291                   AMMRES = AMNAMA ( AMNRES, IBRES, ICRES )
20292
20293 *  common FKFINU
20294                   TV = ZERO
20295 *   kinetic energy of residual nucleus
20296                   TVRECL = PRCL(I,4)-AMRCL(I)
20297 *   excitation energy of residual nucleus
20298                   TVCMS  = EEXC(I)
20299                   PTOLD  = PTRES
20300                   PTRES  = SQRT(ABS(TVRECL*(TVRECL+
20301      &                          2.0D0*(AMMRES+TVCMS))))
20302                   IF (PTOLD.LT.ANGLGB) THEN
20303                      CALL DT_RACO(PXRES,PYRES,PZRES)
20304                      PTOLD = ONE
20305                   ENDIF
20306                   PXRES = PXRES*PTRES/PTOLD
20307                   PYRES = PYRES*PTRES/PTOLD
20308                   PZRES = PZRES*PTRES/PTOLD
20309 * zero counter of secondaries from evaporation
20310                   NP = 0
20311 * evaporation
20312                   WE = ONE
20313
20314                   NPHEAV = 0
20315                   LRNFSS = .FALSE.
20316                   LFRAGM = .FALSE.
20317                   CALL EVEVAP(WE)
20318
20319 * put evaporated particles and residual nuclei to DTEVT1
20320                   MO = NHKK
20321                   CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
20322                ENDIF
20323                EEXCFI(I) = EXCITF
20324                EXCEVA(I) = EXCEVA(I)+EXCITF
20325             ENDIF
20326    13    CONTINUE
20327       ENDIF
20328
20329       RETURN
20330
20331 C9998 IREXCI(1) = IREXCI(1)+1
20332  9998 IREJ   = IREJ+1
20333  9999 CONTINUE
20334       LRCLPR = .TRUE.
20335       LRCLTA = .TRUE.
20336       IREJ   = IREJ+1
20337       RETURN
20338       END
20339
20340 *$ CREATE DT_EVA2HE.FOR
20341 *COPY DT_EVA2HE
20342 *                                                                      *
20343 *====eva2he============================================================*
20344 *                                                                      *
20345       SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
20346
20347 ************************************************************************
20348 * Interface between common's of evaporation module (FKFINU,FKFHVY)     *
20349 * and DTEVT1.                                                          *
20350 *    MO    DTEVT1-index of "mother" (residual) nucleus before evap.    *
20351 *    EEXCF exitation energy of residual nucleus after evaporation      *
20352 *    IRCL  = 1 projectile residual nucleus                             *
20353 *          = 2 target     residual nucleus                             *
20354 * This version dated 19.04.95 is written by S. Roesler.                *
20355 *                                                                      *
20356 * Last change 27.12.2006 by S. Roesler.                                *
20357 ************************************************************************
20358
20359       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20360       SAVE
20361
20362       PARAMETER ( LINP = 10 ,
20363      &            LOUT = 6 ,
20364      &            LDAT = 9 )
20365
20366       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
20367
20368 * event history
20369
20370       PARAMETER (NMXHKK=200000)
20371
20372       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
20373      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
20374      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
20375 * Note: DTEVT2 - special use for heavy fragments !
20376 *       (IDRES(I) = mass number, IDXRES(I) = charge)
20377
20378 * extended event history
20379       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
20380      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
20381      &                IHIST(2,NMXHKK)
20382
20383 * particle properties (BAMJET index convention)
20384       CHARACTER*8  ANAME
20385       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20386      &                IICH(210),IIBAR(210),K1(210),K2(210)
20387
20388 * flags for input different options
20389       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20390       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20391      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20392
20393 * statistics: residual nuclei
20394       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
20395      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
20396      &                NINCST(2,4),NINCEV(2),
20397      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
20398      &                NRESPB(2),NRESCH(2),NRESEV(4),
20399      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
20400      &                NEVAFI(2,2)
20401
20402 * treatment of residual nuclei: properties of residual nuclei
20403       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
20404      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
20405      &                NTOTFI(2),NPROFI(2)
20406
20407 *      INCLUDE '(DIMPAR)'
20408 *     Taken from FLUKA
20409       PARAMETER ( MXXRGN =20000 )
20410       PARAMETER ( MXXMDF =  710 )
20411       PARAMETER ( MXXMDE =  702 )
20412       PARAMETER ( MFSTCK =40000 )
20413       PARAMETER ( MESTCK =  100 )
20414       PARAMETER ( MOSTCK = 2000 )
20415       PARAMETER ( MXPRSN =  100 )
20416       PARAMETER ( MXPDPM =  800 )
20417       PARAMETER ( MXPSCS =30000 )
20418       PARAMETER ( MXGLWN =  300 )
20419       PARAMETER ( MXOUTU =   50 )
20420       PARAMETER ( NALLWP =   64 )
20421       PARAMETER ( NELEMX =   80 )
20422       PARAMETER ( MPDPDX =   18 )
20423       PARAMETER ( MXHTTR =  260 )
20424       PARAMETER ( MXSEAX =   20 )
20425       PARAMETER ( MXHTNC = MXSEAX + 1 )
20426       PARAMETER ( ICOMAX = 2400 )
20427       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
20428       PARAMETER ( NSTBIS =  304 )
20429       PARAMETER ( NQSTIS =   46 )
20430       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
20431       PARAMETER ( MXPABL =  120 )
20432       PARAMETER ( IDMAXP =  450 )
20433       PARAMETER ( IDMXDC = 2000 )
20434       PARAMETER ( MXMCIN =  410 )
20435       PARAMETER ( IHYPMX =    4 )
20436       PARAMETER ( MKBMX1 =   11 )
20437       PARAMETER ( MKBMX2 =   11 )
20438       PARAMETER ( MXIRRD = 2500 )
20439       PARAMETER ( MXTRDC = 1500 )
20440       PARAMETER ( NKTL   =   17 )
20441       PARAMETER ( NBLNMX = 40000000 )
20442
20443 *      INCLUDE '(GENSTK)'
20444 *     Taken from FLUKA
20445       PARAMETER ( MXP = MXPSCS )
20446 *
20447       COMMON / GENSTK /                CXR    (MXPSCS), CYR    (MXPSCS),
20448      &                CZR    (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
20449      &                CZRPOL (MXPSCS), TKI    (MXPSCS), PLR    (MXPSCS),
20450      &                WEI    (MXPSCS), AGESEC (MXPSCS), TV    , TVCMS  ,
20451      &                TVRECL,  TVHEAV, TVBIND,
20452      &                KPART  (MXPSCS), INFEXT (MXPSCS), NP0   , NP
20453
20454 *      INCLUDE '(RESNUC)'
20455       LOGICAL LRNFSS, LFRAGM
20456       COMMON /RESNUC/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
20457      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
20458      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
20459      &                  PYRES,  PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
20460      &                 ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
20461      &                  KTARP,  KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
20462      &                 IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,  ICRES,
20463      &                  IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
20464      &                 IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
20465      &                 IEV4HE, IDEEXG,  IBTAR, ICHTAR, IBLEFT, ICLEFT,
20466      &                 ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
20467      &                 LRNFSS, LFRAGM
20468 *     Taken from FLUKA
20469
20470 *      INCLUDE '(FHEAVY)'
20471 *     Taken from FLUKA
20472       PARAMETER ( MXHEAV = 100 )
20473       PARAMETER ( KXHEAV =  30 )
20474       CHARACTER*8 ANHEAV
20475       COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20476      &                  CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20477      &                  PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20478      &                  AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
20479      &                  AMHEAV (KXHEAV), AMNHEA (KXHEAV),
20480      &                  KHEAVY (MXHEAV), INFHEA (MXHEAV),
20481      &                  ICHEAV (KXHEAV), IBHEAV (KXHEAV),
20482      &                  IMHEAV (KXHEAV), IHHEAV (KXHEAV),
20483      &                  KHHEAV (IHYPMX,KXHEAV), NPHEAV
20484       COMMON / FHEAVC / ANHEAV (KXHEAV)
20485
20486       DIMENSION IPTOKP(39)
20487       DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
20488      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
20489      & 100, 101, 97, 102, 98, 103, 109, 115 /
20490
20491       IREJ = 0
20492
20493 * skip if evaporation package is not included
20494       IF (.NOT.LEVAPO) RETURN
20495
20496 * update counter
20497       IF (NRESEV(3).NE.NEVHKK) THEN
20498          NRESEV(3) = NEVHKK
20499          NRESEV(4) = NRESEV(4)+1
20500       ENDIF
20501
20502       IF (LEMCCK)
20503      &   CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
20504      &                                                   IDUM,IDUM)
20505 * mass number/charge of residual nucleus before evaporation
20506       IBTOT = IDRES(MO)
20507       IZTOT = IDXRES(MO)
20508
20509 * protons/neutrons/gammas
20510       DO 1 I=1,NP
20511          PX    = CXR(I)*PLR(I)
20512          PY    = CYR(I)*PLR(I)
20513          PZ    = CZR(I)*PLR(I)
20514          ID    = IPTOKP(KPART(I))
20515          IDPDG = IDT_IPDGHA(ID)
20516          AM    = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
20517      &           (2.0D0*MAX(TKI(I),TINY10))
20518          IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
20519             WRITE(LOUT,1000) ID,AM,AAM(ID)
20520  1000       FORMAT(1X,'EVA2HE:  inconsistent mass of evap. ',
20521      &             'particle',I3,2E10.3)
20522          ENDIF
20523          PE = TKI(I)+AM
20524          CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
20525          NOBAM(NHKK) = IRCL
20526          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20527          IBTOT = IBTOT-IIBAR(ID)
20528          IZTOT = IZTOT-IICH(ID)
20529     1 CONTINUE
20530
20531 * heavy fragments
20532       DO 2 I=1,NPHEAV
20533          PX     = CXHEAV(I)*PHEAVY(I)
20534          PY     = CYHEAV(I)*PHEAVY(I)
20535          PZ     = CZHEAV(I)*PHEAVY(I)
20536          IDHEAV = 80000
20537          AM     = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
20538      &            (2.0D0*MAX(TKHEAV(I),TINY10))
20539          PE     = TKHEAV(I)+AM
20540          CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
20541      &                  IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
20542          NOBAM(NHKK) = IRCL
20543          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20544          IBTOT = IBTOT-IBHEAV(KHEAVY(I))
20545          IZTOT = IZTOT-ICHEAV(KHEAVY(I))
20546     2 CONTINUE
20547
20548       IF (IBRES.GT.0) THEN
20549 * residual nucleus after evaporation
20550          IDNUC = 80000
20551          CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
20552      &                                        IBRES,ICRES,0)
20553          NOBAM(NHKK) = IRCL
20554       ENDIF
20555       EEXCF = TVCMS
20556       NTOTFI(IRCL) = IBRES
20557       NPROFI(IRCL) = ICRES
20558       IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
20559       IBTOT = IBTOT-IBRES
20560       IZTOT = IZTOT-ICRES
20561
20562 * count events with fission
20563       NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
20564       IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
20565
20566 * energy-momentum conservation check
20567       IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
20568 C     IF (IREJ.GT.0) THEN
20569 C        CALL DT_EVTOUT(4)
20570 C        WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
20571 C     ENDIF
20572 * baryon-number/charge conservation check
20573       IF (IBTOT+IZTOT.NE.0) THEN
20574          WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
20575  1001    FORMAT(1X,'EVA2HE:   baryon-number/charge conservation ',
20576      &          'failure at event ',I8,' :  IBTOT,IZTOT = ',2I3)
20577       ENDIF
20578
20579       RETURN
20580       END
20581
20582 *$ CREATE DT_EBIND.FOR
20583 *COPY DT_EBIND
20584 *
20585 *===ebind==============================================================*
20586 *
20587       DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
20588
20589 ************************************************************************
20590 * Binding energy for nuclei.                                           *
20591 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972)                  *
20592 *                 IA        mass number                                *
20593 *                 IZ        atomic number                              *
20594 * This version dated 5.5.95   is updated by S. Roesler.                *
20595 ************************************************************************
20596
20597       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20598       SAVE
20599
20600       PARAMETER ( LINP = 10 ,
20601      &            LOUT = 6 ,
20602      &            LDAT = 9 )
20603
20604       PARAMETER (ZERO=0.0D0)
20605
20606       DATA       A1,       A2,        A3,        A4,      A5
20607      &     / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
20608
20609       IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
20610          WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0.  ',IA,IZ
20611          DT_EBIND = ZERO
20612          RETURN
20613       ENDIF
20614       AA = IA
20615       DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
20616      &        -A4*(IA-2*IZ)**2/AA
20617       IF (MOD(IA,2).EQ.1) THEN
20618          IA5 = 0
20619       ELSEIF (MOD(IZ,2).EQ.1) THEN
20620          IA5 = 1
20621       ELSE
20622          IA5 = -1
20623       ENDIF
20624       DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
20625
20626       RETURN
20627       END
20628
20629 ************************************************************************
20630 *                                                                      *
20631 *  DPMJET 3.0:   cross section routines                                *
20632 *                                                                      *
20633 ************************************************************************
20634 *
20635 *
20636 *     SUBROUTINE DT_SHNDIF
20637 *         diffractive cross sections (all energies)
20638 *     SUBROUTINE DT_PHOXS
20639 *         total and inel. cross sections from PHOJET interpol. tables
20640 *     SUBROUTINE DT_XSHN
20641 *         total and el. cross sections for all energies
20642 *     SUBROUTINE DT_SIHNAB
20643 *         pion 2-nucleon absorption cross sections
20644 *     SUBROUTINE DT_SIGEMU
20645 *         cross section for target "compounds"
20646 *     SUBROUTINE DT_SIGGA
20647 *         photon nucleus cross sections
20648 *     SUBROUTINE DT_SIGGAT
20649 *         photon nucleus cross sections from tables
20650 *     SUBROUTINE DT_SANO
20651 *         anomalous hard photon-nucleon cross sections from tables
20652 *     SUBROUTINE DT_SIGGP
20653 *         photon nucleon cross sections
20654 *     SUBROUTINE DT_SIGVEL
20655 *         quasi-elastic vector meson prod. cross sections
20656 *     DOUBLE PRECISION FUNCTION DT_SIGVP
20657 *         sigma_VN(tilde)
20658 *     DOUBLE PRECISION FUNCTION DT_RRM2
20659 *     DOUBLE PRECISION FUNCTION DT_RM2
20660 *     DOUBLE PRECISION FUNCTION DT_SAM2
20661 *     SUBROUTINE DT_CKMT
20662 *     SUBROUTINE DT_CKMTX
20663 *     SUBROUTINE DT_PDF0
20664 *     SUBROUTINE DT_CKMTQ0
20665 *     SUBROUTINE DT_CKMTDE
20666 *     SUBROUTINE DT_CKMTPR
20667 *     FUNCTION DT_CKMTFF
20668 *
20669 *     SUBROUTINE DT_FLUINI
20670 *         total nucleon cross section fluctuation treatment
20671 *
20672 *     SUBROUTINE DT_SIGTBL
20673 *         pre-tabulation of low-energy elastic x-sec. using SIHNEL
20674 *     SUBROUTINE DT_XSTABL
20675 *         service routines
20676 *
20677 *
20678 *$ CREATE DT_SHNDIF.FOR
20679 *COPY DT_SHNDIF
20680 *
20681 *===shndif===============================================================*
20682 *
20683       SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
20684
20685 **********************************************************************
20686 *   Single diffractive hadron-nucleon cross sections                 *
20687 *                                              S.Roesler 14/1/93     *
20688 *                                                                    *
20689 *   The cross sections are calculated from extrapolated single       *
20690 *   diffractive antiproton-proton cross sections (DTUJET92) using    *
20691 *   scaling relations between total and single diffractive cross     *
20692 *   sections.                                                        *
20693 **********************************************************************
20694
20695       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20696       SAVE
20697       PARAMETER (ZERO=0.0D0)
20698
20699 * particle properties (BAMJET index convention)
20700       CHARACTER*8  ANAME
20701       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20702      &                IICH(210),IIBAR(210),K1(210),K2(210)
20703 *
20704       CSD1   =   4.201483727D0
20705       CSD4   = -0.4763103556D-02
20706       CSD5   =  0.4324148297D0
20707 *
20708       CHMSD1 =  0.8519297242D0
20709       CHMSD4 = -0.1443076599D-01
20710       CHMSD5 =  0.4014954567D0
20711 *
20712       EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
20713       PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
20714 *
20715       SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20716       SHMSD  = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
20717       FRAC   = SHMSD/SDIAPP
20718 *
20719       GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
20720      &     999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
20721      &      10, 10, 20, 20, 20) KPROJ
20722 *
20723    10 CONTINUE
20724 *---------------------------- p - p , n - p , sigma0+- - p ,
20725 *                             Lambda - p
20726       CSD1   =  6.004476070D0
20727       CSD4   = -0.1257784606D-03
20728       CSD5   =  0.2447335720D0
20729       SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20730       SIGDIH = FRAC*SIGDIF
20731       RETURN
20732 *
20733    20 CONTINUE
20734 *
20735       KPSCAL = 2
20736       KTSCAL = 1
20737 C     F      = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
20738       DUMZER = ZERO
20739       CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
20740       F      = SDIAPP/SIGTO
20741       KT     = 1
20742 C     SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
20743       CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
20744       SIGDIF = SIGTO*F
20745       SIGDIH = FRAC*SIGDIF
20746       RETURN
20747 *
20748   999 CONTINUE
20749 *-------------------------- leptons..
20750       SIGDIF = 1.D-10
20751       SIGDIH = 1.D-10
20752       RETURN
20753       END
20754
20755 *$ CREATE DT_PHOXS.FOR
20756 *COPY DT_PHOXS
20757 *
20758 *===phoxs================================================================*
20759 *
20760       SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
20761
20762 ************************************************************************
20763 * Total/inelastic proton-nucleon cross sections taken from PHOJET-     *
20764 * interpolation tables.                                                *
20765 * This version dated 05.11.97 is written by S. Roesler                 *
20766 ************************************************************************
20767
20768       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20769       SAVE
20770
20771       PARAMETER ( LINP = 10 ,
20772      &            LOUT = 6 ,
20773      &            LDAT = 9 )
20774
20775       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20776       PARAMETER (TWOPI  = 6.283185307179586454D+00,
20777      &           PI     = TWOPI/TWO,
20778      &           GEV2MB = 0.38938D0)
20779
20780       LOGICAL LFIRST
20781       DATA LFIRST /.TRUE./
20782
20783 * nucleon-nucleon event-generator
20784       CHARACTER*8 CMODEL
20785       LOGICAL LPHOIN
20786       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20787
20788 * particle properties (BAMJET index convention)
20789       CHARACTER*8  ANAME
20790       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20791      &                IICH(210),IIBAR(210),K1(210),K2(210)
20792
20793 **PHOJET105a
20794 C     PARAMETER (IEETAB=10)
20795 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20796 **PHOJET110
20797
20798 C  energy-interpolation table
20799       INTEGER IEETA2
20800       PARAMETER ( IEETA2 = 20 )
20801       INTEGER ISIMAX
20802       DOUBLE PRECISION SIGTAB,SIGECM
20803       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20804 **
20805
20806       IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
20807          WRITE(LOUT,*) MCGENE
20808  1000    FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
20809          STOP
20810       ENDIF
20811
20812       IF (ECM.LE.ZERO) THEN
20813          EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
20814          ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
20815       ENDIF
20816
20817       IF (MODE.EQ.1) THEN
20818 * DL
20819          DELDL = 0.0808D0
20820          EPSDL = -0.4525D0
20821          S     = ECM*ECM
20822          STOT  = 21.7D0*S**DELDL+56.08D0*S**EPSDL
20823          ALPHAP= 0.25D0
20824          BEL   = 8.5D0+2.D0*ALPHAP*LOG(S)
20825          SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
20826          SINE  = STOT-SIGEL
20827          SDIF1 = ZERO
20828       ELSE
20829 * Phojet
20830          IP = 1
20831          IF(ECM.LE.SIGECM(IP,1)) THEN
20832            I1 = 1
20833            I2 = 1
20834          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
20835            DO 1 I=2,ISIMAX
20836               IF (ECM.LE.SIGECM(IP,I)) GOTO 2
20837     1      CONTINUE
20838     2      CONTINUE
20839            I1 = I-1
20840            I2 = I
20841          ELSE
20842            IF (LFIRST) THEN
20843               WRITE(LOUT,'(/1X,A,2E12.3)')
20844      &          'PHOXS: warning! energy above initialization limit (',
20845      &          ECM,SIGECM(IP,ISIMAX)
20846              LFIRST = .FALSE.
20847            ENDIF
20848            I1 = ISIMAX
20849            I2 = ISIMAX
20850          ENDIF
20851          FAC2 = ZERO
20852          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
20853      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
20854          FAC1  = ONE-FAC2
20855          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
20856          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
20857          SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
20858      &           FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
20859          BEL   = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
20860       ENDIF
20861
20862       RETURN
20863       END
20864
20865 *$ CREATE DT_XSHN.FOR
20866 *COPY DT_XSHN
20867 *
20868 *===xshn===============================================================*
20869 *
20870       SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
20871
20872 ************************************************************************
20873 * Total and elastic hadron-nucleon cross section.                      *
20874 * Below 500GeV cross sections are based on the '98 data compilation    *
20875 * of the PDG. At higher energies PHOJET results are used (patched to   *
20876 * the low energy data at 500GeV).                                      *
20877 *     IP      projectile index (BAMJET numbering scheme)               *
20878 *             (should be in the range 1..25)                           *
20879 *     IT      target index (BAMJET numbering scheme)                   *
20880 *             (1 = proton, 8 = neutron)                                *
20881 *     PL      laboratory momentum                                      *
20882 *     ECM     cm. energy (ignored if PL>0)                             *
20883 *     STOT    total cross section                                      *
20884 *     SELA    elastic cross section                                    *
20885 * Last change: 24.4.99 by S. Roesler                                   *
20886 ************************************************************************
20887
20888       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20889       SAVE
20890
20891       PARAMETER ( LINP = 10 ,
20892      &            LOUT = 6 ,
20893      &            LDAT = 9 )
20894
20895       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
20896
20897       PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
20898      &           PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
20899       PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
20900
20901       LOGICAL LFIRST
20902
20903 * particle properties (BAMJET index convention)
20904       CHARACTER*8  ANAME
20905       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20906      &                IICH(210),IIBAR(210),K1(210),K2(210)
20907
20908 * nucleon-nucleon event-generator
20909       CHARACTER*8 CMODEL
20910       LOGICAL LPHOIN
20911       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20912 **PHOJET105a
20913 C     PARAMETER (IEETAB=10)
20914 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20915 **PHOJET110
20916
20917 C  energy-interpolation table
20918       INTEGER IEETA2
20919       PARAMETER ( IEETA2 = 20 )
20920       INTEGER ISIMAX
20921       DOUBLE PRECISION SIGTAB,SIGECM
20922       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20923
20924       DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
20925       DIMENSION IDXDAT(25,2)
20926 *
20927       DATA APL /
20928      &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
20929      &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
20930      &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
20931      &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
20932      & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
20933      & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
20934      & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
20935 *
20936 * total cross sections:
20937 * p p
20938       DATA (ASIGTO(1,K),K=1,NPOINT) /
20939      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
20940      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
20941      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
20942      & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
20943      & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
20944      & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
20945      & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
20946 * pbar p
20947       DATA (ASIGTO(2,K),K=1,NPOINT) /
20948      & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
20949      & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
20950      & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
20951      & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
20952      & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
20953      & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
20954      & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
20955 * n p
20956       DATA (ASIGTO(3,K),K=1,NPOINT) /
20957      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
20958      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
20959      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
20960      & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
20961      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
20962      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
20963      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
20964 * pi+ p
20965       DATA (ASIGTO(4,K),K=1,NPOINT) /
20966      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
20967      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
20968      & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
20969      & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
20970      & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
20971      & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
20972      & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
20973 * pi- p
20974       DATA (ASIGTO(5,K),K=1,NPOINT) /
20975      & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
20976      & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
20977      & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
20978      & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
20979      & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
20980      & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
20981      & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
20982 * K+ p
20983       DATA (ASIGTO(6,K),K=1,NPOINT) /
20984      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
20985      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
20986      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
20987      & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
20988      & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
20989      & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
20990      & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
20991 * K- p
20992       DATA (ASIGTO(7,K),K=1,NPOINT) /
20993      & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
20994      & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
20995      & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
20996      & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
20997      & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
20998      & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
20999      & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21000 * K+ n
21001       DATA (ASIGTO(8,K),K=1,NPOINT) /
21002      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21003      & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21004      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21005      & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21006      & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21007      & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21008      & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21009 * K- n
21010       DATA (ASIGTO(9,K),K=1,NPOINT) /
21011      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21012      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21013      & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21014      & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21015      & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21016      & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21017      & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21018 * Lambda p
21019       DATA (ASIGTO(10,K),K=1,NPOINT) /
21020      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21021      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21022      & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21023      & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21024      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21025      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21026      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21027 *
21028 * elastic cross sections:
21029 * p p
21030       DATA (ASIGEL(1,K),K=1,NPOINT) /
21031      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21032      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21033      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21034      & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21035      & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21036      & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21037      & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21038 * pbar p
21039       DATA (ASIGEL(2,K),K=1,NPOINT) /
21040      & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21041      & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21042      & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21043      & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21044      & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21045      & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21046      & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21047 * n p
21048       DATA (ASIGEL(3,K),K=1,NPOINT) /
21049      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21050      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21051      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21052      & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21053      & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21054      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21055      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21056 * pi+ p
21057       DATA (ASIGEL(4,K),K=1,NPOINT) /
21058      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21059      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21060      & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21061      & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21062      & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21063      & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21064      & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21065 * pi- p
21066       DATA (ASIGEL(5,K),K=1,NPOINT) /
21067      & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21068      & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21069      & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21070      & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21071      & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21072      & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21073      & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21074 * K+ p
21075       DATA (ASIGEL(6,K),K=1,NPOINT) /
21076      & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21077      & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21078      & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21079      & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21080      & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21081      & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21082      & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21083 * K- p
21084       DATA (ASIGEL(7,K),K=1,NPOINT) /
21085      & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21086      & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21087      & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21088      & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21089      & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21090      & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21091      & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21092 * K+ n
21093       DATA (ASIGEL(8,K),K=1,NPOINT) /
21094      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21095      & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21096      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21097      & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21098      & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21099      & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21100      & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21101 * K- n
21102       DATA (ASIGEL(9,K),K=1,NPOINT) /
21103      & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21104      & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21105      & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21106      & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21107      & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21108      & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21109      & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21110 * Lambda p
21111       DATA (ASIGEL(10,K),K=1,NPOINT) /
21112      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21113      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21114      & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21115      & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21116      & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21117      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21118      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21119
21120       DATA (IDXDAT(K,1),K=1,25) /
21121      &  1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21122      &  1, 3,45, 8, 9/
21123       DATA (IDXDAT(K,2),K=1,25) /
21124      &  3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21125      &  3, 1,45, 6, 7/
21126
21127       DATA LFIRST /.TRUE./
21128
21129       IF (LFIRST) THEN
21130          APLABL = LOG10(PLABLO)
21131          APLABH = LOG10(PLABHI)
21132          APTHRE = LOG10(PTHRE)
21133          ADP1   = (APTHRE-APLABL)/DBLE(NPOIN1)
21134          ADP2   = (APLABH-APTHRE)/DBLE(NPOIN2)
21135          DUM0   = ZERO
21136          PHOPLA = PLABHI
21137          PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21138          ECMS   = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21139          IF (MCGENE.EQ.2) THEN
21140             IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21141                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21142             ELSE
21143                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21144             ENDIF
21145          ELSE
21146             CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21147          ENDIF
21148          PHOSEL = PHOSTO-PHOSIN
21149          APHOST = LOG10(PHOSTO)
21150          APHOSE = LOG10(PHOSEL)
21151          LFIRST = .FALSE.
21152       ENDIF
21153       STOT = ZERO
21154       SELA = ZERO
21155       PLAB = PL
21156       ECMS = ECM
21157       IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21158          WRITE(LOUT,1000) IP,IT
21159  1000    FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21160      &          'proj/target',2I4)
21161          STOP
21162       ENDIF
21163
21164       IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21165          ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21166          PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21167       ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21168          WRITE(LOUT,1001) PLAB,ECMS
21169  1001    FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21170          STOP
21171       ENDIF
21172
21173 * index of spectrum
21174       IDXP = IP
21175       IF (IP.GT.25) THEN
21176          IF (AAM(IP).GT.ZERO) THEN
21177             IF (ABS(IIBAR(IP)).GT.0) THEN
21178                IDXP = 1
21179             ELSE
21180                IDXP = 13
21181             ENDIF
21182          ELSE
21183             IDXP = 7
21184          ENDIF
21185       ENDIF
21186       IDXT = 1
21187       IF (IT.EQ.8) IDXT = 2
21188       IDXS = IDXDAT(IDXP,IDXT)
21189       IF (IDXS.EQ.0) RETURN
21190
21191 * compute momentum bin indices
21192       IF (PLAB.LT.PLABLO) THEN
21193          IDX0 = 1
21194          IDX1 = 1
21195       ELSEIF (PLAB.GE.PLABHI) THEN
21196          IDX0 = NPOINT
21197          IDX1 = NPOINT
21198       ELSE
21199          APLAB = LOG10(PLAB)
21200          IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21201             IDX0 = INT((APLAB-APLABL)/ADP1)+1
21202          ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21203             IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21204          ENDIF
21205          IDX1 = IDX0+1
21206       ENDIF
21207
21208 * interpolate cross section
21209       IF (IDXS.GT.10) THEN
21210          IDXS1 = IDXS/10
21211          IDXS2 = IDXS-10*IDXS1
21212          IF (IDX0.EQ.IDX1) THEN
21213             IF (IDX0.EQ.1) THEN
21214                ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21215                ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21216             ELSE
21217                DUM0   = ZERO
21218                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21219                PHOSEL = PHOSTO-PHOSIN
21220                ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21221                ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21222                ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21223                ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21224                ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21225                ASELA  = 0.5D0*(ASELA1+ASELA2)
21226             ENDIF
21227          ELSE
21228             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21229             ASTOT1 = ASIGTO(IDXS1,IDX0)+
21230      &               FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21231             ASTOT2 = ASIGTO(IDXS2,IDX0)+
21232      &               FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21233             ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21234             ASELA1 = ASIGEL(IDXS1,IDX0)+
21235      &               FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21236             ASELA2 = ASIGEL(IDXS2,IDX0)+
21237      &               FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21238             ASELA  = 0.5D0*(ASELA1+ASELA2)
21239          ENDIF
21240       ELSE
21241          IF (IDX0.EQ.IDX1) THEN
21242             IF (IDX0.EQ.1) THEN
21243                ASTOT = ASIGTO(IDXS,IDX0)
21244                ASELA = ASIGEL(IDXS,IDX0)
21245             ELSE
21246                DUM0   = ZERO
21247                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21248                PHOSEL = PHOSTO-PHOSIN
21249                ASTOT  = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21250                ASELA  = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21251             ENDIF
21252          ELSE
21253             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21254             ASTOT = ASIGTO(IDXS,IDX0)+
21255      &              FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21256             ASELA = ASIGEL(IDXS,IDX0)+
21257      &              FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21258          ENDIF
21259       ENDIF
21260       STOT = 10.0D0**ASTOT
21261       SELA = 10.0D0**ASELA
21262
21263       RETURN
21264       END
21265
21266 *$ CREATE DT_SIHNAB.FOR
21267 *COPY DT_SIHNAB
21268 *
21269 *===sihnab===============================================================*
21270 *
21271       SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21272
21273 **********************************************************************
21274 * Pion 2-nucleon absorption cross sections.                          *
21275 * (sigma_tot for pi+ d --> p p, pi- d --> n n                        *
21276 *  taken from Ritchie PRC 28 (1983) 926 )                            *
21277 * This version dated 18.05.96 is written by S. Roesler               *
21278 **********************************************************************
21279
21280       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21281       SAVE
21282       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21283       PARAMETER (AMPR = 938.0D0,
21284      &           AMPI = 140.0D0,
21285      &           AMDE = TWO*AMPR,
21286      &           A    = -1.2D0,
21287      &           B    = 3.5D0,
21288      &           C    = 7.4D0,
21289      &           D    = 5600.0D0,
21290      &           ER   = 2136.0D0)
21291
21292       SIGABS = ZERO
21293       IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21294      &                   .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21295       PTOT = PLAB*1.0D3
21296       EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21297       IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21298       ECM  = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21299       SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21300 * approximate 3N-abs., I=1-abs. etc.
21301       SIGABS = SIGABS/0.40D0
21302 * pi0-absorption (rough approximation!!)
21303       IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21304
21305       RETURN
21306       END
21307
21308 *$ CREATE DT_SIGEMU.FOR
21309 *COPY DT_SIGEMU
21310 *
21311 *===sigemu=============================================================*
21312 *
21313       SUBROUTINE DT_SIGEMU
21314
21315 ************************************************************************
21316 * Combined cross section for target compounds.                         *
21317 * This version dated 6.4.98   is written by S. Roesler                 *
21318 ************************************************************************
21319
21320       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21321       SAVE
21322
21323       PARAMETER ( LINP = 10 ,
21324      &            LOUT = 6 ,
21325      &            LDAT = 9 )
21326
21327       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21328      &           OHALF=0.5D0,ONE=1.0D0)
21329
21330       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21331
21332 * Glauber formalism: cross sections
21333       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21334      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21335      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21336      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21337      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21338      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21339      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21340      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21341      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21342      &                BSLOPE,NEBINI,NQBINI
21343
21344 * emulsion treatment
21345       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21346      &                NCOMPO,IEMUL
21347
21348 * nucleon-nucleon event-generator
21349       CHARACTER*8 CMODEL
21350       LOGICAL LPHOIN
21351       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21352
21353       IF (MCGENE.NE.4) THEN
21354          WRITE(LOUT,'(A)') ' DT_SIGEMU:    Combined cross sections'
21355          WRITE(LOUT,'(15X,A)') '-----------------------'
21356       ENDIF
21357       DO 1 IE=1,NEBINI
21358          DO 2 IQ=1,NQBINI
21359             SIGTOT = ZERO
21360             SIGELA = ZERO
21361             SIGQEP = ZERO
21362             SIGQET = ZERO
21363             SIGQE2 = ZERO
21364             SIGPRO = ZERO
21365             SIGDEL = ZERO
21366             SIGDQE = ZERO
21367             ERRTOT = ZERO
21368             ERRELA = ZERO
21369             ERRQEP = ZERO
21370             ERRQET = ZERO
21371             ERRQE2 = ZERO
21372             ERRPRO = ZERO
21373             ERRDEL = ZERO
21374             ERRDQE = ZERO
21375             IF (NCOMPO.GT.0) THEN
21376                DO 3 IC=1,NCOMPO
21377                   SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21378                   SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21379                   SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21380                   SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21381                   SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21382                   SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21383                   SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21384                   SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21385                   ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21386                   ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21387                   ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21388                   ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21389                   ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21390                   ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21391                   ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21392                   ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21393     3          CONTINUE
21394                ERRTOT = SQRT(ERRTOT)
21395                ERRELA = SQRT(ERRELA)
21396                ERRQEP = SQRT(ERRQEP)
21397                ERRQET = SQRT(ERRQET)
21398                ERRQE2 = SQRT(ERRQE2)
21399                ERRPRO = SQRT(ERRPRO)
21400                ERRDEL = SQRT(ERRDEL)
21401                ERRDQE = SQRT(ERRDQE)
21402             ELSE
21403                SIGTOT = XSTOT(IE,IQ,1)
21404                SIGELA = XSELA(IE,IQ,1)
21405                SIGQEP = XSQEP(IE,IQ,1)
21406                SIGQET = XSQET(IE,IQ,1)
21407                SIGQE2 = XSQE2(IE,IQ,1)
21408                SIGPRO = XSPRO(IE,IQ,1)
21409                SIGDEL = XSDEL(IE,IQ,1)
21410                SIGDQE = XSDQE(IE,IQ,1)
21411                ERRTOT = XETOT(IE,IQ,1)
21412                ERRELA = XEELA(IE,IQ,1)
21413                ERRQEP = XEQEP(IE,IQ,1)
21414                ERRQET = XEQET(IE,IQ,1)
21415                ERRQE2 = XEQE2(IE,IQ,1)
21416                ERRPRO = XEPRO(IE,IQ,1)
21417                ERRDEL = XEDEL(IE,IQ,1)
21418                ERRDQE = XEDQE(IE,IQ,1)
21419             ENDIF
21420             IF (MCGENE.NE.4) THEN
21421                WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21422  1000         FORMAT(/,1X,'E_cm =',F9.1,' GeV  Q^2 =',F6.1,' GeV^2 :',/)
21423                WRITE(LOUT,1001) SIGTOT,ERRTOT
21424  1001          FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21425                WRITE(LOUT,1002) SIGELA,ERRELA
21426  1002          FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21427                WRITE(LOUT,1003) SIGQEP,ERRQEP
21428  1003          FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21429      &                F11.5,' mb')
21430                WRITE(LOUT,1004) SIGQET,ERRQET
21431  1004          FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21432      &                F11.5,' mb')
21433                WRITE(LOUT,1005) SIGQE2,ERRQE2
21434  1005          FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21435      &                ' +-',F11.5,' mb')
21436                WRITE(LOUT,1006) SIGPRO,ERRPRO
21437  1006          FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21438                WRITE(LOUT,1007) SIGDEL,ERRDEL
21439  1007          FORMAT(1X,'diff-el   ',27X,F10.4,' +-',F11.5,' mb')
21440                WRITE(LOUT,1008) SIGDQE,ERRDQE
21441  1008          FORMAT(1X,'diff-qel  ',27X,F10.4,' +-',F11.5,' mb')
21442             ENDIF
21443
21444     2    CONTINUE
21445     1 CONTINUE
21446
21447       RETURN
21448       END
21449
21450 *$ CREATE DT_SIGGA.FOR
21451 *COPY DT_SIGGA
21452 *
21453 *===sigga==============================================================*
21454 *
21455       SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21456
21457 ************************************************************************
21458 * Total/inelastic photon-nucleus cross sections.                       *
21459 *     !!!! Overwrites SHMAKI-initialization. Do not use it during      *
21460 *          production runs !!!!                                        *
21461 * This version dated 27.03.96 is written by S. Roesler                 *
21462 ************************************************************************
21463
21464       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21465       SAVE
21466
21467       PARAMETER ( LINP = 10 ,
21468      &            LOUT = 6 ,
21469      &            LDAT = 9 )
21470
21471       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21472      &           OHALF=0.5D0,ONE=1.0D0)
21473       PARAMETER (AMPROT = 0.938D0)
21474
21475       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21476
21477 * Glauber formalism: cross sections
21478       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21479      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21480      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21481      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21482      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21483      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21484      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21485      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21486      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21487      &                BSLOPE,NEBINI,NQBINI
21488
21489       NT  = NTI
21490       X   = XI
21491       Q2  = Q2I
21492       ECM = ECMI
21493       XNU = XNUI
21494       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21495      &   ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21496       CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21497       STOT  = XSTOT(1,1,1)
21498       ETOT  = XETOT(1,1,1)
21499       SIN   = XSPRO(1,1,1)
21500       EIN   = XEPRO(1,1,1)
21501
21502       RETURN
21503       END
21504
21505 *$ CREATE DT_SIGGAT.FOR
21506 *COPY DT_SIGGAT
21507 *
21508 *===siggat=============================================================*
21509 *
21510       SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21511
21512 ************************************************************************
21513 * Total/inelastic photon-nucleus cross sections.                       *
21514 * Uses pre-tabulated cross section.                                    *
21515 * This version dated 29.07.96 is written by S. Roesler                 *
21516 ************************************************************************
21517
21518       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21519       SAVE
21520
21521       PARAMETER ( LINP = 10 ,
21522      &            LOUT = 6 ,
21523      &            LDAT = 9 )
21524
21525       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21526      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21527
21528       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21529
21530 * Glauber formalism: cross sections
21531       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21532      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21533      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21534      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21535      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21536      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21537      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21538      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21539      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21540      &                BSLOPE,NEBINI,NQBINI
21541
21542       NTARG = ABS(NT)
21543       I1   = 1
21544       I2   = 1
21545       RATE = ONE
21546       IF (NEBINI.GT.1) THEN
21547          IF (ECMI.GE.ECMNN(NEBINI)) THEN
21548             I1   = NEBINI
21549             I2   = NEBINI
21550             RATE = ONE
21551          ELSEIF (ECMI.GT.ECMNN(1)) THEN
21552             DO 1 I=2,NEBINI
21553                IF (ECMI.LT.ECMNN(I)) THEN
21554                   I1   = I-1
21555                   I2   = I
21556                   RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21557                   GOTO 2
21558                ENDIF
21559     1       CONTINUE
21560     2       CONTINUE
21561          ENDIF
21562       ENDIF
21563       J1   = 1
21564       J2   = 1
21565       RATQ = ONE
21566       IF (NQBINI.GT.1) THEN
21567          IF (Q2I.GE.Q2G(NQBINI)) THEN
21568             J1   = NQBINI
21569             J2   = NQBINI
21570             RATQ = ONE
21571          ELSEIF (Q2I.GT.Q2G(1)) THEN
21572             DO 3 I=2,NQBINI
21573                IF (Q2I.LT.Q2G(I)) THEN
21574                   J1   = I-1
21575                   J2   = I
21576                   RATQ = LOG10(    Q2I/MAX(Q2G(J1),TINY14))/
21577      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21578 C                 RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21579                   GOTO 4
21580                ENDIF
21581     3       CONTINUE
21582     4       CONTINUE
21583          ENDIF
21584       ENDIF
21585
21586       STOT = XSTOT(I1,J1,NTARG)+
21587      &   RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21588      &   RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21589      &   RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21590      &              XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21591
21592       RETURN
21593       END
21594
21595 *$ CREATE DT_SANO.FOR
21596 *COPY DT_SANO
21597 *
21598 *===sigano=============================================================*
21599 *
21600       DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21601
21602 ************************************************************************
21603 * This version dated 31.07.96 is written by S. Roesler                 *
21604 ************************************************************************
21605
21606       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21607       SAVE
21608
21609       PARAMETER ( LINP = 10 ,
21610      &            LOUT = 6 ,
21611      &            LDAT = 9 )
21612
21613       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21614      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21615       PARAMETER (NE = 8)
21616
21617 * VDM parameter for photon-nucleus interactions
21618       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21619
21620 * properties of interacting particles
21621       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
21622
21623       DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
21624       DATA ECMANO /
21625      &             0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
21626      &             0.100D+04,0.200D+04,0.500D+04
21627      &            /
21628 * fixed cut (3 GeV/c)
21629       DATA FRAANO /
21630      &             0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
21631      &             0.062D+00,0.054D+00,0.042D+00
21632      &            /
21633       DATA SIGHRD /
21634      &           4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
21635      &           3.3086D-01,7.6255D-01,2.1319D+00
21636      &            /
21637 * running cut (based on obsolete Phojet-caluclations, bugs..)
21638 C     DATA FRAANO /
21639 C    &             0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
21640 C    &             0.167E+00,0.150E+00,0.131E+00
21641 C    &            /
21642 C     DATA SIGHRD /
21643 C    &           6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
21644 C    &           2.5736E-01,4.5593E-01,8.2550E-01
21645 C    &            /
21646
21647       DT_SANO = ZERO
21648       IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
21649       J1   = 0
21650       J2   = 0
21651       RATE = ONE
21652       IF (ECM.GE.ECMANO(NE)) THEN
21653          J1 = NE
21654          J2 = NE
21655       ELSEIF (ECM.GT.ECMANO(1)) THEN
21656          DO 1 IE=2,NE
21657             IF (ECM.LT.ECMANO(IE)) THEN
21658                J1   = IE-1
21659                J2   = IE
21660                RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
21661                GOTO 2
21662             ENDIF
21663     1    CONTINUE
21664     2    CONTINUE
21665       ENDIF
21666       IF ((J1.GT.0).AND.(J2.GT.0)) THEN
21667          AFRA1  = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
21668          AFRA2  = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
21669          DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
21670       ENDIF
21671
21672       RETURN
21673       END
21674
21675 *$ CREATE DT_SIGGP.FOR
21676 *COPY DT_SIGGP
21677 *
21678 *===siggp==============================================================*
21679 *
21680       SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
21681
21682 ************************************************************************
21683 * Total/inelastic photon-nucleon cross sections.                       *
21684 * This version dated 30.04.96 is written by S. Roesler                 *
21685 ************************************************************************
21686
21687       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21688       SAVE
21689
21690       PARAMETER ( LINP = 10 ,
21691      &            LOUT = 6 ,
21692      &            LDAT = 9 )
21693
21694       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21695       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
21696      &           PI     = TWOPI/TWO,
21697      &           GEV2MB = 0.38938D0,
21698      &           ALPHEM = ONE/137.0D0)
21699
21700 * particle properties (BAMJET index convention)
21701       CHARACTER*8  ANAME
21702       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21703      &                IICH(210),IIBAR(210),K1(210),K2(210)
21704
21705 * VDM parameter for photon-nucleus interactions
21706       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21707
21708 **PHOJET105a
21709 C     CHARACTER*8 MDLNA
21710 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
21711 C     PARAMETER (IEETAB=10)
21712 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21713 **PHOJET110
21714
21715 C  model switches and parameters
21716       CHARACTER*8 MDLNA
21717       INTEGER ISWMDL,IPAMDL
21718       DOUBLE PRECISION PARMDL
21719       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21720
21721 C  energy-interpolation table
21722       INTEGER IEETA2
21723       PARAMETER ( IEETA2 = 20 )
21724       INTEGER ISIMAX
21725       DOUBLE PRECISION SIGTAB,SIGECM
21726       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21727 **
21728
21729 C     PARAMETER (NPOINT=80)
21730       PARAMETER (NPOINT=16)
21731       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
21732
21733       STOT = ZERO
21734       SINE = ZERO
21735       SDIR = ZERO
21736
21737       W2 = ECMI**2
21738       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21739      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21740       Q2 = Q2I
21741       X  = XI
21742 * photoprod.
21743       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21744          Q2 = 0.0001D0
21745          X  = Q2/(W2+Q2-AAM(1)**2)
21746 * DIS
21747       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21748          X  = Q2/(W2+Q2-AAM(1)**2)
21749       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21750          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21751       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21752          W2 = Q2*(ONE-X)/X+AAM(1)**2
21753       ELSE
21754          WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
21755          STOP
21756       ENDIF
21757       ECM = SQRT(W2)
21758
21759       IF (MODEGA.EQ.1) THEN
21760          SCALE = SQRT(Q2)
21761          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21762      &                                                       IDPDF)
21763 C        W = SQRT(W2)
21764
21765 C        ALLMF2 = PHO_ALLM97(Q2,W)
21766
21767 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
21768          STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
21769          SINE = ZERO
21770          SDIR = ZERO
21771       ELSEIF (MODEGA.EQ.2) THEN
21772          IF (INTRGE(1).EQ.1) THEN
21773             AMLO2 = (3.0D0*AAM(13))**2
21774          ELSEIF (INTRGE(1).EQ.2) THEN
21775             AMLO2 = AAM(33)**2
21776          ELSE
21777             AMLO2 = AAM(96)**2
21778          ENDIF
21779          IF (INTRGE(2).EQ.1) THEN
21780             AMHI2 = W2/TWO
21781          ELSEIF (INTRGE(2).EQ.2) THEN
21782             AMHI2 = W2/4.0D0
21783          ELSE
21784             AMHI2 = W2
21785          ENDIF
21786          AMHI20 = (ECM-AAM(1))**2
21787          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
21788          XAMLO  = LOG( AMLO2+Q2 )
21789          XAMHI  = LOG( AMHI2+Q2 )
21790 **PHOJET105a
21791 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21792 **PHOJET112
21793
21794          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21795
21796 **
21797          SUM  = ZERO
21798          DO 1 J=1,NPOINT
21799             AM2 = EXP(ABSZX(J))-Q2
21800             IF (AM2.LT.16.0D0) THEN
21801                R = TWO
21802             ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
21803                R = 10.0D0/3.0D0
21804             ELSE
21805                R = 11.0D0/3.0D0
21806             ENDIF
21807 C           FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21808             FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21809      &            * (ONE+EPSPOL*Q2/AM2)
21810             SUM = SUM+WEIGHT(J)*FAC
21811     1    CONTINUE
21812          SINE = SUM
21813          SDIR = DT_SIGVP(X,Q2)
21814          STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
21815          SDIR = SDIR/(0.588D0+RL2+Q2)
21816 C        STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
21817       ELSEIF (MODEGA.EQ.3) THEN
21818          CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
21819       ELSEIF (MODEGA.EQ.4) THEN
21820 *  load cross sections from PHOJET interpolation table
21821          IP = 1
21822          IF(ECM.LE.SIGECM(IP,1)) THEN
21823            I1 = 1
21824            I2 = 1
21825          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21826            DO 2 I=2,ISIMAX
21827               IF (ECM.LE.SIGECM(IP,I)) GOTO 3
21828     2      CONTINUE
21829     3      CONTINUE
21830            I1 = I-1
21831            I2 = I
21832          ELSE
21833            WRITE(LOUT,'(/1X,A,2E12.3)')
21834      &       'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
21835            I1 = ISIMAX
21836            I2 = ISIMAX
21837          ENDIF
21838          FAC2 = ZERO
21839          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21840      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21841          FAC1 = ONE-FAC2
21842 *  cross section dependence on photon virtuality
21843          FSUP1 = ZERO
21844          DO 4 I=1,3
21845             FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
21846      &                                /(1.D0+Q2/PARMDL(30+I))**2
21847     4    CONTINUE
21848          FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
21849          FAC1  = FAC1*FSUP1
21850          FAC2  = FAC2*FSUP1
21851          FSUP2 = 1.0D0
21852          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21853          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21854          SDIR  = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
21855 **re:
21856          STOT  = STOT-SDIR
21857 **
21858          SDIR  = SDIR/(FSUP1*FSUP2)
21859 **re:
21860          STOT  = STOT+SDIR
21861 **
21862       ENDIF
21863
21864       RETURN
21865       END
21866
21867 *$ CREATE DT_SIGVEL.FOR
21868 *COPY DT_SIGVEL
21869 *
21870 *===sigvel=============================================================*
21871 *
21872       SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
21873
21874 ************************************************************************
21875 * Cross section for elastic vector meson production                    *
21876 * This version dated 10.05.96 is written by S. Roesler                 *
21877 ************************************************************************
21878
21879       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21880       SAVE
21881
21882       PARAMETER ( LINP = 10 ,
21883      &            LOUT = 6 ,
21884      &            LDAT = 9 )
21885
21886       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21887       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
21888      &           PI     = TWOPI/TWO,
21889      &           GEV2MB = 0.38938D0,
21890      &           ALPHEM = ONE/137.0D0)
21891
21892 * particle properties (BAMJET index convention)
21893       CHARACTER*8  ANAME
21894       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21895      &                IICH(210),IIBAR(210),K1(210),K2(210)
21896
21897 * VDM parameter for photon-nucleus interactions
21898       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21899
21900       W2 = ECMI**2
21901       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21902      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21903       Q2 = Q2I
21904       X  = XI
21905 * photoprod.
21906       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21907          Q2 = 0.0001D0
21908          X  = Q2/(W2+Q2-AAM(1)**2)
21909 * DIS
21910       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21911          X  = Q2/(W2+Q2-AAM(1)**2)
21912       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21913          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21914       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21915          W2 = Q2*(ONE-X)/X+AAM(1)**2
21916       ELSE
21917          WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
21918          STOP
21919       ENDIF
21920       ECM = SQRT(W2)
21921
21922       AMV  = AAM(IDXV)
21923       AMV2 = AMV**2
21924
21925       BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
21926      &        +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
21927       ROSH   = 0.1D0
21928       STOVP  = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
21929       SELVP  = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
21930
21931       IF (IDXV.EQ.33) THEN
21932          COUPL = 0.00365D0
21933       ELSE
21934          STOP
21935       ENDIF
21936       SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
21937       SIG2 = SELVP
21938       SVEL  = COUPL * (AMV2/(AMV2+Q2))**2
21939      &              * (ONE+EPSPOL*Q2/AMV2) * SELVP
21940
21941       RETURN
21942       END
21943
21944 *$ CREATE DT_SIGVP.FOR
21945 *COPY DT_SIGVP
21946 *
21947 *===sigvp==============================================================*
21948 *
21949       DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
21950
21951 ************************************************************************
21952 * sigma_Vp                                                             *
21953 ************************************************************************
21954
21955       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21956       SAVE
21957
21958       PARAMETER ( LINP = 10 ,
21959      &            LOUT = 6 ,
21960      &            LDAT = 9 )
21961
21962       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21963       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21964      &           PI    = TWOPI/TWO,
21965      &           GEV2MB = 0.38938D0,
21966      &           AMPROT = 0.938D0,
21967      &           ALPHEM = ONE/137.0D0)
21968
21969 * VDM parameter for photon-nucleus interactions
21970       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21971
21972       X  = XI
21973       Q2 = Q2I
21974       IF (XI.LE.ZERO)  X  = 0.0001D0
21975       IF (Q2I.LE.ZERO) Q2 = 0.0001D0
21976
21977       ECM    = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
21978
21979       SCALE = SQRT(Q2)
21980       IF (MODEGA.EQ.1) THEN
21981          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21982      &                                                       IDPDF)
21983 C        W = ECM
21984
21985 C        ALLMF2 = PHO_ALLM97(Q2,W)
21986
21987 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
21988 C        STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
21989 C        DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
21990          DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
21991       ELSEIF (MODEGA.EQ.4) THEN
21992          CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
21993 C        F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
21994          DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
21995       ELSE
21996          STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
21997       ENDIF
21998
21999       RETURN
22000
22001       END
22002
22003 *$ CREATE DT_RRM2.FOR
22004 *COPY DT_RRM2
22005 *
22006 *===RRM2===============================================================*
22007 *
22008       DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22009
22010       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22011       SAVE
22012
22013       PARAMETER ( LINP = 10 ,
22014      &            LOUT = 6 ,
22015      &            LDAT = 9 )
22016
22017       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22018       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22019      &           PI    = TWOPI/TWO,
22020      &           GEV2MB = 0.38938D0)
22021
22022 * particle properties (BAMJET index convention)
22023       CHARACTER*8  ANAME
22024       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22025      &                IICH(210),IIBAR(210),K1(210),K2(210)
22026
22027 * VDM parameter for photon-nucleus interactions
22028       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22029
22030       S   = Q2*(ONE-X)/X+AAM(1)**2
22031       ECM = SQRT(S)
22032
22033       IF (INTRGE(1).EQ.1) THEN
22034          AMLO2 = (3.0D0*AAM(13))**2
22035       ELSEIF (INTRGE(1).EQ.2) THEN
22036          AMLO2 = AAM(33)**2
22037       ELSE
22038          AMLO2 = AAM(96)**2
22039       ENDIF
22040       IF (INTRGE(2).EQ.1) THEN
22041          AMHI2 = S/TWO
22042       ELSEIF (INTRGE(2).EQ.2) THEN
22043          AMHI2 = S/4.0D0
22044       ELSE
22045          AMHI2 = S
22046       ENDIF
22047       AMHI20 = (ECM-AAM(1))**2
22048       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22049
22050       AM1C2 = 16.0D0
22051       AM2C2 = 121.0D0
22052       IF (AMHI2.LE.AM1C2) THEN
22053          DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22054       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22055          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22056      &          10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22057       ELSE
22058          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22059      &          10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22060      &          11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22061       ENDIF
22062
22063       RETURN
22064       END
22065
22066 *$ CREATE DT_RM2.FOR
22067 *COPY DT_RM2
22068 *
22069 *===RM2================================================================*
22070 *
22071       DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22072
22073       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22074       SAVE
22075
22076       PARAMETER ( LINP = 10 ,
22077      &            LOUT = 6 ,
22078      &            LDAT = 9 )
22079
22080       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22081       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22082      &           PI    = TWOPI/TWO,
22083      &           GEV2MB = 0.38938D0)
22084
22085 * VDM parameter for photon-nucleus interactions
22086       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22087
22088       IF (RL2.LE.ZERO) THEN
22089          DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22090      &        (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22091      &         +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22092       ELSE
22093          TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22094          TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22095          DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22096      &       -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22097      &       +EPSPOL*(
22098      &         -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22099      &       -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22100       ENDIF
22101
22102       RETURN
22103       END
22104
22105 *$ CREATE DT_SAM2.FOR
22106 *COPY DT_SAM2
22107 *
22108 *===SAM2===============================================================*
22109 *
22110       DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22111
22112       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22113       SAVE
22114
22115       PARAMETER ( LINP = 10 ,
22116      &            LOUT = 6 ,
22117      &            LDAT = 9 )
22118
22119       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22120      &           TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22121       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22122      &           PI    = TWOPI/TWO,
22123      &           GEV2MB = 0.38938D0)
22124
22125 * particle properties (BAMJET index convention)
22126       CHARACTER*8  ANAME
22127       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22128      &                IICH(210),IIBAR(210),K1(210),K2(210)
22129
22130 * VDM parameter for photon-nucleus interactions
22131       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22132
22133       S = ECM**2
22134       IF (INTRGE(1).EQ.1) THEN
22135          AMLO2 = (3.0D0*AAM(13))**2
22136       ELSEIF (INTRGE(1).EQ.2) THEN
22137          AMLO2 = AAM(33)**2
22138       ELSE
22139          AMLO2 = AAM(96)**2
22140       ENDIF
22141       IF (INTRGE(2).EQ.1) THEN
22142          AMHI2 = S/TWO
22143       ELSEIF (INTRGE(2).EQ.2) THEN
22144          AMHI2 = S/4.0D0
22145       ELSE
22146          AMHI2 = S
22147       ENDIF
22148       AMHI20 = (ECM-AAM(1))**2
22149       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22150
22151       AM1C2 = 16.0D0
22152       AM2C2 = 121.0D0
22153       YLO   = LOG(AMLO2+Q2)
22154       YC1   = LOG(AM1C2+Q2)
22155       YC2   = LOG(AM2C2+Q2)
22156       YHI   = LOG(AMHI2+Q2)
22157       IF (AMHI2.LE.AM1C2) THEN
22158          FACHI = TWO
22159       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22160          FACHI = TENTRD
22161       ELSE
22162          FACHI = ELVTRD
22163       ENDIF
22164
22165     1 CONTINUE
22166       YSAM2  = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22167       IF (YSAM2.LE.YC1) THEN
22168          FAC = TWO
22169       ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22170          FAC = TENTRD
22171       ELSE
22172          FAC = ELVTRD
22173       ENDIF
22174       WEIGMX = FACHI*(ONE-Q2*EXP(  -YHI))
22175       XSAM2  = FAC  *(ONE-Q2*EXP(-YSAM2))
22176       IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22177
22178       DT_SAM2   = EXP(YSAM2)-Q2
22179
22180       RETURN
22181       END
22182
22183 *$ CREATE DT_CKMT.FOR
22184 *COPY DT_CKMT
22185 *
22186 *===ckmt===============================================================*
22187 *
22188       SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22189      &                F2,IPAR)
22190
22191 ************************************************************************
22192 * This version dated 31.01.96 is written by S. Roesler                 *
22193 ************************************************************************
22194
22195       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22196       SAVE
22197
22198       PARAMETER ( LINP = 10 ,
22199      &            LOUT = 6 ,
22200      &            LDAT = 9 )
22201
22202       PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22203
22204       PARAMETER (Q02 = 2.0D0,
22205      &           DQ2 = 10.05D0,
22206      &           Q12 = Q02+DQ2)
22207
22208       DIMENSION PD(-6:6),SEA(3),VAL(2)
22209
22210       CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22211       CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22212       ADQ2 = LOG10(Q12)-LOG10(Q02)
22213       F2P  = (F2Q1-F2Q0)/ADQ2
22214       CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22215       CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22216       F2PP = (F2PQ1-F2PQ0)/ADQ2
22217       FX   = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22218
22219       Q2     = MAX(SCALE**2.0D0,TINY10)
22220       SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22221       IF (Q2.LT.Q02) THEN
22222          CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22223          UPV  = VAL(1)
22224          DNV  = VAL(2)
22225          USEA = SEA(1)
22226          DSEA = SEA(2)
22227          STR  = SEA(3)
22228          CHM  = 0.0D0
22229          BOT  = 0.0D0
22230          TOP  = 0.0D0
22231          GL   = GLU
22232       ELSE
22233          CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22234          F2 = F2*SMOOTH
22235          UPV  = PD(2)-PD(3)
22236          DNV  = PD(1)-PD(3)
22237          USEA = PD(3)
22238          DSEA = PD(3)
22239          STR  = PD(3)
22240          CHM  = PD(4)
22241          BOT  = PD(5)
22242          TOP  = PD(6)
22243          GL   = PD(0)
22244 C        UPV  = UPV*SMOOTH
22245 C        DNV  = DNV*SMOOTH
22246 C        USEA = USEA*SMOOTH
22247 C        DSEA = DSEA*SMOOTH
22248 C        STR  = STR*SMOOTH
22249 C        CHM  = CHM*SMOOTH
22250 C        GL   = GL*SMOOTH
22251       ENDIF
22252
22253       RETURN
22254       END
22255 C
22256
22257 *$ CREATE DT_CKMTX.FOR
22258 *COPY DT_CKMTX
22259       SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22260 C**********************************************************************
22261 C
22262 C     PDF based on Regge theory, evolved with .... by ....
22263 C
22264 C     input: IPAR     2212   proton (not installed)
22265 C                       45   Pomeron
22266 C                      100   Deuteron
22267 C
22268 C     output: PD(-6:6) x*f(x)  parton distribution functions
22269 C            (PDFLIB convention: d = PD(1), u = PD(2) )
22270 C
22271 C**********************************************************************
22272
22273       SAVE
22274       DOUBLE PRECISION  X,SCALE2,PD(-6:6),CDN,CUP,F2
22275
22276       PARAMETER ( LINP = 10 ,
22277      &            LOUT = 6 ,
22278      &            LDAT = 9 )
22279
22280       DIMENSION QQ(7)
22281 C
22282       Q2=SNGL(SCALE2)
22283       Q1S=Q2
22284       XX=SNGL(X)
22285 C  QCD lambda for evolution
22286       OWLAM = 0.23D0
22287       OWLAM2=OWLAM**2
22288 C  Q0**2 for evolution
22289       Q02 = 2.D0
22290 C
22291 C
22292 C  the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22293 C                        q(6)=x*charm, q(7)=x*gluon
22294 C
22295       SB=0.
22296       IF(Q2-Q02) 1,1,2
22297     2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22298     1 CONTINUE
22299       IF(IPAR.EQ.2212) THEN
22300         CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22301         CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22302         CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22303         CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22304         CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22305         CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22306         CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22307 C     ELSEIF (IPAR.EQ.45) THEN
22308 C       CALL CKMTPO(1,0,XX,SB,QQ(1))
22309 C       CALL CKMTPO(2,0,XX,SB,QQ(2))
22310 C       CALL CKMTPO(3,0,XX,SB,QQ(3))
22311 C       CALL CKMTPO(4,0,XX,SB,QQ(4))
22312 C       CALL CKMTPO(5,0,XX,SB,QQ(5))
22313 C       CALL CKMTPO(8,0,XX,SB,QQ(6))
22314 C       CALL CKMTPO(7,0,XX,SB,QQ(7))
22315       ELSEIF (IPAR.EQ.100) THEN
22316         CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22317         CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22318         CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22319         CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22320         CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22321         CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22322         CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22323       ELSE
22324         WRITE(LOUT,'(1X,A,I4,A)')
22325      &     'CKMTX:   IPAR =',IPAR,' not implemented!'
22326         STOP
22327       ENDIF
22328 C
22329       PD(-6) = 0.D0
22330       PD(-5) = 0.D0
22331       PD(-4) = DBLE(QQ(6))
22332       PD(-3) = DBLE(QQ(3))
22333       PD(-2) = DBLE(QQ(4))
22334       PD(-1) = DBLE(QQ(5))
22335       PD(0)  = DBLE(QQ(7))
22336       PD(1)  = DBLE(QQ(2))
22337       PD(2)  = DBLE(QQ(1))
22338       PD(3)  = DBLE(QQ(3))
22339       PD(4)  = DBLE(QQ(6))
22340       PD(5)  = 0.D0
22341       PD(6)  = 0.D0
22342       IF(IPAR.EQ.45) THEN
22343         CDN = (PD(1)-PD(-1))/2.D0
22344         CUP = (PD(2)-PD(-2))/2.D0
22345         PD(-1) = PD(-1) + CDN
22346         PD(-2) = PD(-2) + CUP
22347         PD(1) = PD(-1)
22348         PD(2) = PD(-2)
22349       ENDIF
22350       F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22351      &     1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22352      &     1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22353       END
22354 C
22355
22356 *$ CREATE DT_PDF0.FOR
22357 *COPY DT_PDF0
22358 *
22359 *===pdf0===============================================================*
22360 *
22361       SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22362
22363 ************************************************************************
22364 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22365 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22366 *                   IPAR  = 2212   proton                              *
22367 *                         =  100   deuteron                            *
22368 * This version dated 31.01.96 is written by S. Roesler                 *
22369 ************************************************************************
22370
22371       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22372       SAVE
22373
22374       PARAMETER ( LINP = 10 ,
22375      &            LOUT = 6 ,
22376      &            LDAT = 9 )
22377
22378       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22379
22380       PARAMETER (
22381      &              AA     = 0.1502D0,
22382      &              BBDEU  = 1.2D0,
22383      &              BUD    = 0.754D0,
22384      &              BDD    = 0.4495D0,
22385      &              BUP    = 1.2064D0,
22386      &              BDP    = 0.1798D0,
22387      &              DELTA0 = 0.07684D0,
22388      &              D      = 1.117D0,
22389      &              C      = 3.5489D0,
22390      &              A      = 0.2631D0,
22391      &              B      = 0.6452D0,
22392      &              ALPHAR = 0.415D0,
22393      &              E      = 0.1D0
22394      &          )
22395
22396       PARAMETER (NPOINT=16)
22397 C     DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22398       DIMENSION SEA(3),VAL(2)
22399
22400       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22401       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22402 * proton, deuteron
22403       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22404          CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22405          SEA(1) = 0.75D0*SEA0
22406          SEA(2) = SEA(1)
22407          SEA(3) = SEA(1)
22408          VAL(1) = 9.0D0/4.0D0*VALU0
22409          VAL(2) = 9.0D0*VALD0
22410          GLU0   = SEA(1)/(1.0D0-X)
22411          F2     = SEA0+VALU0+VALD0
22412          F2PDF  = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22413      &            1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22414      &            1.0D0/9.0D0*(2.0D0*SEA(3))
22415          IF (ABS(F2-F2PDF).GT.TINY9) THEN
22416             WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22417             STOP
22418          ENDIF
22419 **PHOJET105a
22420 C        CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22421 **PHOJET112
22422
22423 C        CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22424
22425 **
22426 C        SUMQ = ZERO
22427 C        SUMG = ZERO
22428 C        DO 1 J=1,NPOINT
22429 C           CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22430 C           VALU0 = 9.0D0/4.0D0*VALU0
22431 C           VALD0 = 9.0D0*VALD0
22432 C           SEA0  = 0.75D0*SEA0
22433 C           SUMQ  = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22434 C           SUMG  = SUMG+ (SEA0/(1.0D0-ABSZX(J)))  *WEIGHT(J)
22435 C   1    CONTINUE
22436 C        GLU = GLU0*(1.0D0-SUMQ)/SUMG
22437       ELSE
22438          WRITE(LOUT,'(1X,A,I4,A)')
22439      &      'PDF0:   IPAR =',IPAR,' not implemented!'
22440          STOP
22441       ENDIF
22442
22443       RETURN
22444       END
22445
22446 *$ CREATE DT_CKMTQ0.FOR
22447 *COPY DT_CKMTQ0
22448 *
22449 *===ckmtq0=============================================================*
22450 *
22451       SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22452
22453 ************************************************************************
22454 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22455 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22456 *                   IPAR  = 2212   proton                              *
22457 *                         =  100   deuteron                            *
22458 * This version dated 31.01.96 is written by S. Roesler                 *
22459 ************************************************************************
22460
22461       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22462       SAVE
22463
22464       PARAMETER ( LINP = 10 ,
22465      &            LOUT = 6 ,
22466      &            LDAT = 9 )
22467
22468       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22469
22470       PARAMETER (
22471      &              AA     = 0.1502D0,
22472      &              BBDEU  = 1.2D0,
22473      &              BUD    = 0.754D0,
22474      &              BDD    = 0.4495D0,
22475      &              BUP    = 1.2064D0,
22476      &              BDP    = 0.1798D0,
22477      &              DELTA0 = 0.07684D0,
22478      &              D      = 1.117D0,
22479      &              C      = 3.5489D0,
22480      &              A      = 0.2631D0,
22481      &              B      = 0.6452D0,
22482      &              ALPHAR = 0.415D0,
22483      &              E      = 0.1D0
22484      &          )
22485
22486       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22487       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22488 * proton, deuteron
22489       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22490          IF (IPAR.EQ.2212) THEN
22491             BU = BUP
22492             BD = BDP
22493          ELSE
22494             BU = BUD
22495             BD = BDD
22496          ENDIF
22497          SEA0  = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22498      &          (Q2/(Q2+A))**(1.0D0+DELTA)
22499          VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22500      &           (Q2/(Q2+B))**(ALPHAR)
22501          VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22502      &           (Q2/(Q2+B))**(ALPHAR)
22503       ELSE
22504          WRITE(LOUT,'(1X,A,I4,A)')
22505      &      'CKMTQ0: IPAR =',IPAR,' not implemented!'
22506          STOP
22507       ENDIF
22508       RETURN
22509       END
22510 C
22511 C
22512
22513 *$ CREATE DT_CKMTDE.FOR
22514 *COPY DT_CKMTDE
22515       SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22516 C
22517 C**********************************************************************
22518 C    Deuteron - PDFs
22519 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22520 C    ANS = PDF(I)
22521 C    This version by S. Roesler, 30.01.96
22522 C**********************************************************************
22523
22524       SAVE
22525       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22526       EQUIVALENCE (GF(1,1,1),DL(1))
22527       DATA DELTA/.13/
22528 C
22529       DATA (DL(K),K=    1,   85) /
22530      &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22531      &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22532      &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22533      &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22534      &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22535      &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22536      &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22537      &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22538      &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22539      &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22540      &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22541      &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22542      &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22543      &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22544      &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22545      &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22546      &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22547       DATA (DL(K),K=   86,  170) /
22548      &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22549      &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22550      &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22551      &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22552      &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22553      &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22554      &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22555      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22556      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22557      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22558      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22559      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22560      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22561      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22562      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22563      &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22564      &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22565       DATA (DL(K),K=  171,  255) /
22566      &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22567      &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22568      &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22569      &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22570      &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22571      &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22572      &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22573      &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22574      &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22575      &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22576      &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22577      &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22578      &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22579      &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22580      &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22581      &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22582      &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22583       DATA (DL(K),K=  256,  340) /
22584      &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22585      &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22586      &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22587      &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22588      &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22589      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22590      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22591      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22592      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22593      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22594      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22595      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22596      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22597      &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22598      &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22599      &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22600      &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22601       DATA (DL(K),K=  341,  425) /
22602      &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22603      &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22604      &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22605      &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22606      &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22607      &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22608      &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22609      &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22610      &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22611      &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22612      &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22613      &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22614      &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22615      &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22616      &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22617      &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22618      &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22619       DATA (DL(K),K=  426,  510) /
22620      &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22621      &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22622      &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22623      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22624      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22625      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22626      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22627      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22628      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22629      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22630      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22631      &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22632      &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22633      &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22634      &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22635      &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22636      &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22637       DATA (DL(K),K=  511,  595) /
22638      &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22639      &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22640      &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22641      &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22642      &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22643      &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22644      &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22645      &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22646      &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22647      &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22648      &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22649      &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22650      &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22651      &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22652      &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
22653      &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
22654      &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
22655       DATA (DL(K),K=  596,  680) /
22656      &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
22657      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22658      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22659      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22660      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22661      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22662      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22663      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22664      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22665      &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22666      &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
22667      &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
22668      &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
22669      &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
22670      &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
22671      &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
22672      &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
22673       DATA (DL(K),K=  681,  765) /
22674      &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
22675      &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
22676      &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
22677      &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
22678      &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
22679      &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
22680      &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
22681      &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
22682      &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
22683      &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
22684      &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
22685      &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
22686      &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
22687      &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
22688      &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
22689      &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
22690      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22691       DATA (DL(K),K=  766,  850) /
22692      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22693      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22694      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22695      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22696      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22697      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22698      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22699      &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
22700      &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
22701      &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
22702      &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
22703      &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
22704      &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
22705      &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
22706      &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
22707      &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
22708      &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
22709       DATA (DL(K),K=  851,  935) /
22710      &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
22711      &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
22712      &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
22713      &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
22714      &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
22715      &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
22716      &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
22717      &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
22718      &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
22719      &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
22720      &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
22721      &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
22722      &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
22723      &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
22724      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22725      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22726      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22727       DATA (DL(K),K=  936, 1020) /
22728      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22729      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22730      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22731      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22732      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22733      &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
22734      &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
22735      &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
22736      &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
22737      &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
22738      &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
22739      &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
22740      &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
22741      &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
22742      &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
22743      &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
22744      &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
22745       DATA (DL(K),K= 1021, 1105) /
22746      &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
22747      &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
22748      &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
22749      &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
22750      &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
22751      &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
22752      &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
22753      &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
22754      &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
22755      &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
22756      &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
22757      &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
22758      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22759      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22760      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22761      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22762      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22763       DATA (DL(K),K= 1106, 1190) /
22764      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22765      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22766      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22767      &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
22768      &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
22769      &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
22770      &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
22771      &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
22772      &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
22773      &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
22774      &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
22775      &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
22776      &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
22777      &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
22778      &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
22779      &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
22780      &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
22781       DATA (DL(K),K= 1191, 1275) /
22782      &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
22783      &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
22784      &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
22785      &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
22786      &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
22787      &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
22788      &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
22789      &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
22790      &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
22791      &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
22792      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22793      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22794      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22795      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22796      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22797      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22798      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22799       DATA (DL(K),K= 1276, 1360) /
22800      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22801      &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
22802      &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
22803      &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
22804      &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
22805      &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
22806      &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
22807      &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
22808      &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
22809      &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
22810      &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
22811      &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
22812      &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
22813      &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
22814      &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
22815      &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
22816      &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
22817       DATA (DL(K),K= 1361, 1445) /
22818      &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
22819      &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
22820      &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
22821      &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
22822      &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
22823      &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
22824      &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
22825      &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
22826      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22827      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22828      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22829      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22830      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22831      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22832      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22833      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22834      &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
22835       DATA (DL(K),K= 1446, 1530) /
22836      &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
22837      &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
22838      &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
22839      &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
22840      &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
22841      &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
22842      &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
22843      &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
22844      &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
22845      &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
22846      &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
22847      &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
22848      &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
22849      &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
22850      &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
22851      &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
22852      &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
22853       DATA (DL(K),K= 1531, 1615) /
22854      &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
22855      &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
22856      &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
22857      &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
22858      &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
22859      &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
22860      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22861      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22862      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22863      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22864      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22865      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22866      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22867      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22868      &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
22869      &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
22870      &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
22871       DATA (DL(K),K= 1616, 1700) /
22872      &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
22873      &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
22874      &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
22875      &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
22876      &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
22877      &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
22878      &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
22879      &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
22880      &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
22881      &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
22882      &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
22883      &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
22884      &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
22885      &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
22886      &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
22887      &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
22888      &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
22889       DATA (DL(K),K= 1701, 1785) /
22890      &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
22891      &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
22892      &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
22893      &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
22894      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22895      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22896      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22897      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22898      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22899      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22900      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22901      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22902      &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
22903      &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
22904      &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
22905      &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
22906      &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
22907       DATA (DL(K),K= 1786, 1870) /
22908      &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
22909      &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
22910      &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
22911      &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
22912      &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
22913      &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
22914      &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
22915      &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
22916      &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
22917      &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
22918      &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
22919      &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
22920      &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
22921      &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
22922      &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
22923      &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
22924      &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
22925       DATA (DL(K),K= 1871, 1955) /
22926      &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
22927      &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
22928      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22929      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22930      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22931      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22932      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22933      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22934      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22935      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22936      &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
22937      &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
22938      &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
22939      &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
22940      &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
22941      &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
22942      &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
22943       DATA (DL(K),K= 1956, 2040) /
22944      &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
22945      &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
22946      &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
22947      &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
22948      &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
22949      &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
22950      &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
22951      &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
22952      &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
22953      &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
22954      &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
22955      &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
22956      &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
22957      &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
22958      &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
22959      &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
22960      &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
22961       DATA (DL(K),K= 2041, 2125) /
22962      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22963      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22964      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22965      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22966      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22967      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22968      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22969      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22970      &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
22971      &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
22972      &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
22973      &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
22974      &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
22975      &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
22976      &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
22977      &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
22978      &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
22979       DATA (DL(K),K= 2126, 2210) /
22980      &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
22981      &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
22982      &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
22983      &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
22984      &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
22985      &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
22986      &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
22987      &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
22988      &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
22989      &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
22990      &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
22991      &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
22992      &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
22993      &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
22994      &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
22995      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22996      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22997       DATA (DL(K),K= 2211, 2295) /
22998      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22999      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23000      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23001      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23002      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23003      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23004      &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23005      &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23006      &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23007      &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23008      &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23009      &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23010      &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23011      &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23012      &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23013      &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23014      &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23015       DATA (DL(K),K= 2296, 2380) /
23016      &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23017      &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23018      &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23019      &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23020      &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23021      &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23022      &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23023      &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23024      &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23025      &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23026      &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23027      &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23028      &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23029      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23030      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23031      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23032      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23033       DATA (DL(K),K= 2381, 2465) /
23034      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23035      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23036      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23037      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23038      &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23039      &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23040      &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23041      &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23042      &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23043      &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23044      &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23045      &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23046      &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23047      &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23048      &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23049      &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23050      &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23051       DATA (DL(K),K= 2466, 2550) /
23052      &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23053      &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23054      &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23055      &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23056      &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23057      &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23058      &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23059      &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23060      &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23061      &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23062      &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23063      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23064      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23065      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23066      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23067      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23068      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23069       DATA (DL(K),K= 2551, 2635) /
23070      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23071      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23072      &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23073      &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23074      &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23075      &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23076      &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23077      &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23078      &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23079      &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23080      &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23081      &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23082      &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23083      &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23084      &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23085      &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23086      &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23087       DATA (DL(K),K= 2636, 2720) /
23088      &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23089      &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23090      &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23091      &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23092      &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23093      &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23094      &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23095      &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23096      &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23097      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23098      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23099      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23100      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23101      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23102      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23103      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23104      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23105       DATA (DL(K),K= 2721, 2805) /
23106      &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23107      &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23108      &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23109      &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23110      &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23111      &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23112      &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23113      &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23114      &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23115      &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23116      &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23117      &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23118      &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23119      &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23120      &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23121      &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23122      &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23123       DATA (DL(K),K= 2806, 2890) /
23124      &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23125      &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23126      &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23127      &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23128      &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23129      &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23130      &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23131      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23132      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23133      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23134      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23135      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23136      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23137      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23138      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23139      &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23140      &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23141       DATA (DL(K),K= 2891, 2975) /
23142      &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23143      &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23144      &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23145      &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23146      &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23147      &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23148      &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23149      &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23150      &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23151      &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23152      &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23153      &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23154      &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23155      &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23156      &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23157      &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23158      &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23159       DATA (DL(K),K= 2976, 3060) /
23160      &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23161      &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23162      &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23163      &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23164      &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23165      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23166      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23167      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23168      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23169      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23170      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23171      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23172      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23173      &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23174      &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23175      &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23176      &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23177       DATA (DL(K),K= 3061, 3145) /
23178      &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23179      &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23180      &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23181      &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23182      &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23183      &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23184      &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23185      &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23186      &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23187      &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23188      &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23189      &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23190      &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23191      &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23192      &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23193      &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23194      &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23195       DATA (DL(K),K= 3146, 3230) /
23196      &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23197      &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23198      &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23199      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23200      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23201      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23202      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23203      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23204      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23205      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23206      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23207      &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23208      &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23209      &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23210      &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23211      &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23212      &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23213       DATA (DL(K),K= 3231, 3315) /
23214      &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23215      &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23216      &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23217      &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23218      &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23219      &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23220      &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23221      &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23222      &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23223      &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23224      &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23225      &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23226      &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23227      &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23228      &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23229      &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23230      &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23231       DATA (DL(K),K= 3316, 3400) /
23232      &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23233      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23234      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23235      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23236      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23237      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23238      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23239      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23240      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23241      &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23242      &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23243      &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23244      &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23245      &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23246      &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23247      &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23248      &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23249       DATA (DL(K),K= 3401, 3485) /
23250      &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23251      &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23252      &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23253      &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23254      &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23255      &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23256      &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23257      &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23258      &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23259      &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23260      &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23261      &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23262      &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23263      &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23264      &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23265      &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23266      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23267       DATA (DL(K),K= 3486, 3570) /
23268      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23269      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23270      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23271      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23272      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23273      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23274      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23275      &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23276      &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23277      &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23278      &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23279      &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23280      &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23281      &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23282      &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23283      &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23284      &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23285       DATA (DL(K),K= 3571, 3655) /
23286      &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23287      &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23288      &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23289      &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23290      &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23291      &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23292      &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23293      &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23294      &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23295      &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23296      &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23297      &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23298      &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23299      &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23300      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23301      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23302      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23303       DATA (DL(K),K= 3656, 3740) /
23304      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23305      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23306      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23307      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23308      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23309      &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23310      &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23311      &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23312      &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23313      &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23314      &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23315      &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23316      &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23317      &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23318      &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23319      &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23320      &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23321       DATA (DL(K),K= 3741, 3825) /
23322      &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23323      &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23324      &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23325      &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23326      &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23327      &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23328      &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23329      &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23330      &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23331      &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23332      &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23333      &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23334      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23335      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23336      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23337      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23338      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23339       DATA (DL(K),K= 3826, 3910) /
23340      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23341      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23342      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23343      &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23344      &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23345      &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23346      &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23347      &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23348      &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23349      &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23350      &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23351      &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23352      &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23353      &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23354      &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23355      &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23356      &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23357       DATA (DL(K),K= 3911, 3995) /
23358      &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23359      &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23360      &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23361      &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23362      &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23363      &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23364      &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23365      &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23366      &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23367      &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23368      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23369      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23370      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23371      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23372      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23373      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23374      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23375       DATA (DL(K),K= 3996, 4000) /
23376      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23377 C
23378       ANS = 0.
23379       IF (X.GT.0.9985) RETURN
23380       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23381 C
23382       IS  = S/DELTA+1
23383       IS1 = IS+1
23384       DO 1 L=1,25
23385          KL    = L+NDRV*25
23386          F1(L) = GF(I,IS,KL)
23387          F2(L) = GF(I,IS1,KL)
23388     1 CONTINUE
23389       A1 = DT_CKMTFF(X,F1)
23390       A2 = DT_CKMTFF(X,F2)
23391 C      A1=ALOG(A1)
23392 C      A2=ALOG(A2)
23393       S1  = (IS-1)*DELTA
23394       S2  = S1+DELTA
23395       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23396 C      ANS=EXP(ANS)
23397       RETURN
23398       END
23399 C
23400 C
23401
23402 *$ CREATE DT_CKMTPR.FOR
23403 *COPY DT_CKMTPR
23404       SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23405 C
23406 C**********************************************************************
23407 C    Proton   - PDFs
23408 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23409 C    ANS = PDF(I)
23410 C    This version by S. Roesler, 31.01.96
23411 C**********************************************************************
23412
23413       SAVE
23414       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23415       EQUIVALENCE (GF(1,1,1),DL(1))
23416       DATA DELTA/.10/
23417 C
23418       DATA (DL(K),K=    1,   85) /
23419      &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23420      &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23421      &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23422      &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23423      &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23424      &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23425      &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23426      &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23427      &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23428      &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23429      &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23430      &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23431      &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23432      &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23433      &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23434      &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23435      &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23436       DATA (DL(K),K=   86,  170) /
23437      &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23438      &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23439      &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23440      &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23441      &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23442      &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23443      &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23444      &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23445      &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23446      &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23447      &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23448      &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23449      &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23450      &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23451      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23452      &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23453      &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23454       DATA (DL(K),K=  171,  255) /
23455      &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23456      &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23457      &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23458      &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23459      &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23460      &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23461      &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23462      &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23463      &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23464      &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23465      &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23466      &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23467      &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23468      &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23469      &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23470      &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23471      &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23472       DATA (DL(K),K=  256,  340) /
23473      &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23474      &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23475      &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23476      &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23477      &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23478      &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23479      &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23480      &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23481      &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23482      &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23483      &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23484      &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23485      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23486      &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23487      &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23488      &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23489      &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23490       DATA (DL(K),K=  341,  425) /
23491      &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23492      &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23493      &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23494      &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23495      &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23496      &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23497      &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23498      &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23499      &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23500      &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23501      &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23502      &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23503      &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23504      &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23505      &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23506      &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23507      &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23508       DATA (DL(K),K=  426,  510) /
23509      &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23510      &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23511      &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23512      &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23513      &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23514      &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23515      &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23516      &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23517      &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23518      &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23519      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23520      &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23521      &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23522      &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23523      &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23524      &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23525      &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23526       DATA (DL(K),K=  511,  595) /
23527      &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23528      &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23529      &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23530      &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23531      &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23532      &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23533      &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23534      &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23535      &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23536      &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23537      &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23538      &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23539      &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23540      &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23541      &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23542      &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23543      &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23544       DATA (DL(K),K=  596,  680) /
23545      &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23546      &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23547      &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23548      &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23549      &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23550      &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23551      &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23552      &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23553      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23554      &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23555      &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23556      &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23557      &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23558      &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23559      &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23560      &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23561      &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23562       DATA (DL(K),K=  681,  765) /
23563      &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23564      &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23565      &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23566      &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23567      &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23568      &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23569      &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23570      &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23571      &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23572      &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23573      &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23574      &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23575      &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23576      &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23577      &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23578      &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23579      &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23580       DATA (DL(K),K=  766,  850) /
23581      &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23582      &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23583      &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23584      &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23585      &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23586      &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23587      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23588      &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23589      &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23590      &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23591      &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23592      &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23593      &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23594      &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23595      &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23596      &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23597      &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23598       DATA (DL(K),K=  851,  935) /
23599      &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23600      &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23601      &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23602      &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23603      &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23604      &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23605      &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23606      &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23607      &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23608      &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23609      &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23610      &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23611      &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23612      &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23613      &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23614      &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23615      &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23616       DATA (DL(K),K=  936, 1020) /
23617      &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23618      &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23619      &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23620      &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23621      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23622      &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23623      &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23624      &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23625      &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23626      &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23627      &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23628      &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23629      &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23630      &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23631      &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23632      &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23633      &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23634       DATA (DL(K),K= 1021, 1105) /
23635      &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23636      &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23637      &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23638      &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23639      &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23640      &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23641      &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23642      &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23643      &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23644      &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23645      &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23646      &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23647      &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23648      &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23649      &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23650      &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23651      &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23652       DATA (DL(K),K= 1106, 1190) /
23653      &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
23654      &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23655      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23656      &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23657      &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
23658      &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
23659      &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
23660      &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
23661      &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
23662      &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
23663      &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
23664      &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
23665      &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
23666      &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
23667      &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
23668      &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
23669      &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
23670       DATA (DL(K),K= 1191, 1275) /
23671      &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
23672      &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
23673      &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
23674      &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
23675      &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
23676      &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
23677      &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
23678      &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
23679      &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
23680      &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
23681      &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
23682      &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
23683      &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
23684      &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
23685      &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
23686      &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
23687      &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
23688       DATA (DL(K),K= 1276, 1360) /
23689      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23690      &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23691      &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
23692      &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
23693      &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
23694      &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
23695      &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
23696      &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
23697      &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
23698      &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
23699      &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
23700      &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
23701      &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
23702      &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
23703      &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
23704      &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
23705      &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
23706       DATA (DL(K),K= 1361, 1445) /
23707      &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
23708      &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
23709      &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
23710      &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
23711      &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
23712      &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
23713      &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
23714      &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
23715      &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
23716      &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
23717      &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
23718      &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
23719      &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
23720      &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
23721      &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23722      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23723      &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23724       DATA (DL(K),K= 1446, 1530) /
23725      &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
23726      &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
23727      &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
23728      &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
23729      &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
23730      &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
23731      &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
23732      &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
23733      &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
23734      &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
23735      &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
23736      &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
23737      &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
23738      &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
23739      &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
23740      &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
23741      &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
23742       DATA (DL(K),K= 1531, 1615) /
23743      &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
23744      &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
23745      &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
23746      &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
23747      &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
23748      &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
23749      &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
23750      &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
23751      &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
23752      &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
23753      &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
23754      &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
23755      &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23756      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23757      &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23758      &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
23759      &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
23760       DATA (DL(K),K= 1616, 1700) /
23761      &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
23762      &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
23763      &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
23764      &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
23765      &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
23766      &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
23767      &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
23768      &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
23769      &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
23770      &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
23771      &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
23772      &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
23773      &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
23774      &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
23775      &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
23776      &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
23777      &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
23778       DATA (DL(K),K= 1701, 1785) /
23779      &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
23780      &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
23781      &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
23782      &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
23783      &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
23784      &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
23785      &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
23786      &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
23787      &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
23788      &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
23789      &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23790      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23791      &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23792      &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
23793      &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
23794      &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
23795      &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
23796       DATA (DL(K),K= 1786, 1870) /
23797      &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
23798      &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
23799      &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
23800      &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
23801      &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
23802      &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
23803      &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
23804      &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
23805      &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
23806      &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
23807      &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
23808      &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
23809      &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
23810      &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
23811      &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
23812      &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
23813      &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
23814       DATA (DL(K),K= 1871, 1955) /
23815      &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
23816      &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
23817      &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
23818      &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
23819      &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
23820      &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
23821      &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
23822      &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
23823      &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23824      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23825      &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23826      &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
23827      &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
23828      &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
23829      &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
23830      &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
23831      &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
23832       DATA (DL(K),K= 1956, 2040) /
23833      &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
23834      &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
23835      &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
23836      &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
23837      &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
23838      &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
23839      &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
23840      &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
23841      &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
23842      &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
23843      &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
23844      &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
23845      &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
23846      &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
23847      &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
23848      &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
23849      &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
23850       DATA (DL(K),K= 2041, 2125) /
23851      &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
23852      &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
23853      &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
23854      &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
23855      &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
23856      &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
23857      &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23858      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23859      &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23860      &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
23861      &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
23862      &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
23863      &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
23864      &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
23865      &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
23866      &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
23867      &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
23868       DATA (DL(K),K= 2126, 2210) /
23869      &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
23870      &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
23871      &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
23872      &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
23873      &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
23874      &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
23875      &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
23876      &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
23877      &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
23878      &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
23879      &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
23880      &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
23881      &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
23882      &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
23883      &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
23884      &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
23885      &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
23886       DATA (DL(K),K= 2211, 2295) /
23887      &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
23888      &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
23889      &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
23890      &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
23891      &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23892      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23893      &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23894      &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
23895      &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
23896      &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
23897      &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
23898      &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
23899      &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
23900      &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
23901      &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
23902      &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
23903      &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
23904       DATA (DL(K),K= 2296, 2380) /
23905      &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
23906      &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
23907      &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
23908      &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
23909      &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
23910      &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
23911      &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
23912      &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
23913      &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
23914      &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
23915      &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
23916      &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
23917      &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
23918      &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
23919      &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
23920      &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
23921      &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
23922       DATA (DL(K),K= 2381, 2465) /
23923      &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
23924      &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
23925      &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23926      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23927      &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23928      &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
23929      &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
23930      &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
23931      &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
23932      &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
23933      &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
23934      &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
23935      &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
23936      &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
23937      &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
23938      &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
23939      &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
23940       DATA (DL(K),K= 2466, 2550) /
23941      &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
23942      &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
23943      &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
23944      &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
23945      &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
23946      &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
23947      &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
23948      &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
23949      &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
23950      &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
23951      &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
23952      &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
23953      &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
23954      &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
23955      &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
23956      &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
23957      &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
23958       DATA (DL(K),K= 2551, 2635) /
23959      &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
23960      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23961      &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
23962      &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
23963      &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
23964      &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
23965      &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
23966      &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
23967      &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
23968      &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
23969      &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
23970      &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
23971      &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
23972      &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
23973      &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
23974      &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
23975      &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
23976       DATA (DL(K),K= 2636, 2720) /
23977      &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
23978      &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
23979      &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
23980      &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
23981      &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
23982      &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
23983      &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
23984      &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
23985      &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
23986      &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
23987      &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
23988      &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
23989      &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
23990      &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
23991      &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
23992      &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
23993      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23994       DATA (DL(K),K= 2721, 2805) /
23995      &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
23996      &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
23997      &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
23998      &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
23999      &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24000      &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24001      &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24002      &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24003      &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24004      &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24005      &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24006      &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24007      &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24008      &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24009      &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24010      &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24011      &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24012       DATA (DL(K),K= 2806, 2890) /
24013      &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24014      &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24015      &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24016      &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24017      &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24018      &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24019      &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24020      &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24021      &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24022      &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24023      &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24024      &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24025      &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24026      &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24027      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24028      &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24029      &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24030       DATA (DL(K),K= 2891, 2975) /
24031      &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24032      &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24033      &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24034      &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24035      &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24036      &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24037      &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24038      &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24039      &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24040      &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24041      &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24042      &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24043      &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24044      &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24045      &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24046      &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24047      &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24048       DATA (DL(K),K= 2976, 3060) /
24049      &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24050      &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24051      &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24052      &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24053      &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24054      &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24055      &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24056      &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24057      &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24058      &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24059      &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24060      &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24061      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24062      &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24063      &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24064      &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24065      &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24066       DATA (DL(K),K= 3061, 3145) /
24067      &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24068      &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24069      &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24070      &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24071      &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24072      &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24073      &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24074      &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24075      &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24076      &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24077      &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24078      &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24079      &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24080      &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24081      &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24082      &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24083      &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24084       DATA (DL(K),K= 3146, 3230) /
24085      &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24086      &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24087      &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24088      &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24089      &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24090      &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24091      &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24092      &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24093      &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24094      &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24095      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24096      &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24097      &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24098      &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24099      &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24100      &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24101      &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24102       DATA (DL(K),K= 3231, 3315) /
24103      &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24104      &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24105      &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24106      &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24107      &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24108      &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24109      &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24110      &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24111      &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24112      &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24113      &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24114      &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24115      &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24116      &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24117      &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24118      &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24119      &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24120       DATA (DL(K),K= 3316, 3400) /
24121      &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24122      &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24123      &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24124      &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24125      &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24126      &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24127      &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24128      &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24129      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24130      &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24131      &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24132      &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24133      &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24134      &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24135      &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24136      &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24137      &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24138       DATA (DL(K),K= 3401, 3485) /
24139      &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24140      &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24141      &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24142      &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24143      &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24144      &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24145      &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24146      &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24147      &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24148      &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24149      &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24150      &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24151      &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24152      &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24153      &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24154      &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24155      &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24156       DATA (DL(K),K= 3486, 3570) /
24157      &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24158      &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24159      &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24160      &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24161      &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24162      &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24163      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24164      &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24165      &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24166      &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24167      &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24168      &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24169      &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24170      &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24171      &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24172      &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24173      &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24174       DATA (DL(K),K= 3571, 3655) /
24175      &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24176      &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24177      &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24178      &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24179      &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24180      &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24181      &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24182      &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24183      &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24184      &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24185      &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24186      &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24187      &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24188      &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24189      &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24190      &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24191      &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24192       DATA (DL(K),K= 3656, 3740) /
24193      &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24194      &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24195      &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24196      &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24197      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24198      &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24199      &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24200      &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24201      &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24202      &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24203      &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24204      &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24205      &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24206      &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24207      &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24208      &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24209      &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24210       DATA (DL(K),K= 3741, 3825) /
24211      &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24212      &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24213      &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24214      &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24215      &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24216      &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24217      &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24218      &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24219      &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24220      &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24221      &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24222      &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24223      &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24224      &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24225      &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24226      &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24227      &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24228       DATA (DL(K),K= 3826, 3910) /
24229      &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24230      &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24231      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24232      &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24233      &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24234      &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24235      &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24236      &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24237      &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24238      &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24239      &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24240      &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24241      &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24242      &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24243      &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24244      &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24245      &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24246       DATA (DL(K),K= 3911, 3995) /
24247      &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24248      &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24249      &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24250      &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24251      &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24252      &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24253      &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24254      &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24255      &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24256      &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24257      &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24258      &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24259      &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24260      &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24261      &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24262      &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24263      &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24264       DATA (DL(K),K= 3996, 4000) /
24265      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24266 C
24267       ANS = 0.
24268       IF (X.GT.0.9985) RETURN
24269       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24270 C
24271       IS  = S/DELTA+1
24272       IS1 = IS+1
24273       DO 1 L=1,25
24274          KL    = L+NDRV*25
24275          F1(L) = GF(I,IS,KL)
24276          F2(L) = GF(I,IS1,KL)
24277     1 CONTINUE
24278       A1 = DT_CKMTFF(X,F1)
24279       A2 = DT_CKMTFF(X,F2)
24280 C      A1=ALOG(A1)
24281 C      A2=ALOG(A2)
24282       S1  = (IS-1)*DELTA
24283       S2  = S1+DELTA
24284       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24285 C      ANS=EXP(ANS)
24286       RETURN
24287       END
24288 C
24289
24290 *$ CREATE DT_CKMTFF.FOR
24291 *COPY DT_CKMTFF
24292       FUNCTION DT_CKMTFF(X,FVL)
24293 C**********************************************************************
24294 C
24295 C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24296 C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24297 C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24298 C     IN MAIN ROUTINE.
24299 C
24300 C**********************************************************************
24301
24302       SAVE
24303       DIMENSION FVL(25),XGRID(25)
24304       DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24305      *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24306 C
24307       DT_CKMTFF=0.
24308       DO 1 I=1,NX
24309       IF(X.LT.XGRID(I)) GO TO 2
24310     1 CONTINUE
24311     2 I=I-1
24312       IF(I.EQ.0) THEN
24313          I=I+1
24314       ELSE IF(I.GT.23) THEN
24315          I=23
24316       ENDIF
24317       J=I+1
24318       K=J+1
24319       AXI=LOG(XGRID(I))
24320       BXI=LOG(1.-XGRID(I))
24321       AXJ=LOG(XGRID(J))
24322       BXJ=LOG(1.-XGRID(J))
24323       AXK=LOG(XGRID(K))
24324       BXK=LOG(1.-XGRID(K))
24325       FI=LOG(ABS(FVL(I)) +1.E-15)
24326       FJ=LOG(ABS(FVL(J)) +1.E-16)
24327       FK=LOG(ABS(FVL(K)) +1.E-17)
24328       DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24329       ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24330      $ BXI))/DET
24331       ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24332       BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24333       IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24334      1RETURN
24335 C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24336 C         WRITE(6,2001) X,FVL
24337 C 2001    FORMAT(8E12.4)
24338 C         WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24339 C      ENDIF
24340       DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24341       RETURN
24342       END
24343
24344 *$ CREATE DT_FLUINI.FOR
24345 *COPY DT_FLUINI
24346 *
24347 *===fluini=============================================================*
24348 *
24349       SUBROUTINE DT_FLUINI
24350
24351 ************************************************************************
24352 * Initialisation of the nucleon-nucleon cross section fluctuation      *
24353 * treatment. The original version by J. Ranft.                         *
24354 * This version dated 21.04.95 is revised by S. Roesler.                *
24355 ************************************************************************
24356
24357       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24358       SAVE
24359
24360       PARAMETER ( LINP = 10 ,
24361      &            LOUT = 6 ,
24362      &            LDAT = 9 )
24363
24364       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24365
24366       PARAMETER ( A     = 0.1D0,
24367      &            B     = 0.893D0,
24368      &            OM    = 1.1D0,
24369      &            N     = 6,
24370      &            DX    = 0.003D0)
24371
24372 * n-n cross section fluctuations
24373       PARAMETER (NBINS = 1000)
24374       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24375       DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24376
24377       WRITE(LOUT,1000)
24378  1000 FORMAT(/,1X,'FLUINI:  hadronic cross section fluctuations ',
24379      &       'treated')
24380
24381       FLUSU  = ZERO
24382       FLUSUU = ZERO
24383
24384       DO 1 I=1,NBINS
24385          X        = DBLE(I)*DX
24386          FLUIX(I) = X
24387          FLUS     = ((X-B)/(OM*B))**N
24388          IF (FLUS.LE.20.0D0) THEN
24389             FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24390          ELSE
24391             FLUSI(I) = ZERO
24392          ENDIF
24393          FLUSU = FLUSU+FLUSI(I)
24394     1 CONTINUE
24395       DO 2 I=1,NBINS
24396          FLUSUU   = FLUSUU+FLUSI(I)/FLUSU
24397          FLUSI(I) = FLUSUU
24398     2 CONTINUE
24399
24400 C     WRITE(LOUT,1001)
24401 C1001 FORMAT(1X,'FLUCTUATIONS')
24402 C     CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24403
24404       DO 3 I=1,NBINS
24405          AF = DBLE(I)*0.001D0
24406          DO 4 J=1,NBINS
24407             IF (AF.LE.FLUSI(J)) THEN
24408                FLUIXX(I) = FLUIX(J)
24409                GOTO 5
24410             ENDIF
24411     4    CONTINUE
24412     5    CONTINUE
24413     3 CONTINUE
24414       FLUIXX(1)     = FLUIX(1)
24415       FLUIXX(NBINS) = FLUIX(NBINS)
24416
24417       RETURN
24418       END
24419
24420 *$ CREATE DT_SIGTBL.FOR
24421 *COPY DT_SIGTBL
24422 *
24423 *===sigtab=============================================================*
24424 *
24425       SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24426
24427 ************************************************************************
24428 * This version dated 18.11.95 is written by S. Roesler                 *
24429 ************************************************************************
24430
24431       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24432       SAVE
24433
24434       PARAMETER ( LINP = 10 ,
24435      &            LOUT = 6 ,
24436      &            LDAT = 9 )
24437
24438       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24439      &           OHALF=0.5D0,ONE=1.0D0)
24440       PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24441
24442       LOGICAL LINIT
24443
24444 * particle properties (BAMJET index convention)
24445       CHARACTER*8  ANAME
24446       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24447      &                IICH(210),IIBAR(210),K1(210),K2(210)
24448
24449       DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24450       DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24451      &             0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24452      &             0, 0, 5/
24453       DATA LINIT /.FALSE./
24454
24455 * precalculation and tabulation of elastic cross sections
24456       IF (ABS(MODE).EQ.1) THEN
24457          IF (MODE.EQ.1)
24458      &      OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24459          PLABLX = LOG10(PLO)
24460          PLABHX = LOG10(PHI)
24461          DPLAB  = (PLABHX-PLABLX)/DBLE(NBINS)
24462          DO 1 I=1,NBINS+1
24463             PLAB = PLABLX+DBLE(I-1)*DPLAB
24464             PLAB = 10**PLAB
24465             DO 2 IPROJ=1,23
24466                IDX = IDSIG(IPROJ)
24467                IF (IDX.GT.0) THEN
24468 C                 CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24469 C                 CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24470                   DUMZER = ZERO
24471                   CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24472                   CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24473                ENDIF
24474     2       CONTINUE
24475             IF (MODE.EQ.1) THEN
24476                WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24477      &                                (SIGEN(IDX,I),IDX=1,5)
24478  1000          FORMAT(F5.1,10F7.2)
24479             ENDIF
24480     1    CONTINUE
24481          IF (MODE.EQ.1) CLOSE(LDAT)
24482          LINIT = .TRUE.
24483       ELSE
24484          SIGE = -ONE
24485          IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24486      &                           .AND.(PTOT.LE.PHI) ) THEN
24487             IDX = IDSIG(JP)
24488             IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24489                PLABX = LOG10(PTOT)
24490                IF (PLABX.LE.PLABLX) THEN
24491                   I1 = 1
24492                   I2 = 1
24493                ELSEIF (PLABX.GE.PLABHX) THEN
24494                   I1 = NBINS+1
24495                   I2 = NBINS+1
24496                ELSE
24497                   I1 = INT((PLABX-PLABLX)/DPLAB)+1
24498                   I2 = I1+1
24499                ENDIF
24500                PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24501                PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24502                PBIN   = PLAB2X-PLAB1X
24503                IF (PBIN.GT.TINY10) THEN
24504                   RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24505                ELSE
24506                   RATX = ZERO
24507                ENDIF
24508                IF (JT.EQ.1) THEN
24509                   SIG1 = SIGEP(IDX,I1)
24510                   SIG2 = SIGEP(IDX,I2)
24511                ELSE
24512                   SIG1 = SIGEN(IDX,I1)
24513                   SIG2 = SIGEN(IDX,I2)
24514                ENDIF
24515                SIGE = SIG1+RATX*(SIG2-SIG1)
24516             ENDIF
24517          ENDIF
24518       ENDIF
24519
24520       RETURN
24521       END
24522
24523 *$ CREATE DT_XSTABL.FOR
24524 *COPY DT_XSTABL
24525 *
24526 *===xstabl=============================================================*
24527 *
24528       SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24529
24530       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24531       SAVE
24532
24533       PARAMETER ( LINP = 10 ,
24534      &            LOUT = 6 ,
24535      &            LDAT = 9 )
24536
24537       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24538      &           OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24539       LOGICAL LLAB,LELOG,LQLOG
24540
24541 * particle properties (BAMJET index convention)
24542       CHARACTER*8  ANAME
24543       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24544      &                IICH(210),IIBAR(210),K1(210),K2(210)
24545
24546 * properties of interacting particles
24547       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24548
24549       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24550
24551 * Glauber formalism: cross sections
24552       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24553      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24554      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24555      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24556      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24557      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24558      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24559      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24560      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24561      &                BSLOPE,NEBINI,NQBINI
24562
24563 * emulsion treatment
24564       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24565      &                NCOMPO,IEMUL
24566
24567       DIMENSION WHAT(6)
24568
24569       LLAB   = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24570       ELO    = ABS(WHAT(1))
24571       EHI    = ABS(WHAT(2))
24572       IF (ELO.GT.EHI) ELO = EHI
24573       LELOG  = WHAT(3).LT.ZERO
24574       NEBINS = MAX(INT(ABS(WHAT(3))),1)
24575       DEBINS = (EHI-ELO)/DBLE(NEBINS)
24576       IF (LELOG) THEN
24577          AELO   = LOG10(ELO)
24578          AEHI   = LOG10(EHI)
24579          ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24580       ENDIF
24581       Q2LO   = WHAT(4)
24582       Q2HI   = WHAT(5)
24583       IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24584       LQLOG  = WHAT(6).LT.ZERO
24585       NQBINS = MAX(INT(ABS(WHAT(6))),1)
24586       DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24587       IF (LQLOG) THEN
24588          AQ2LO  = LOG10(Q2LO)
24589          AQ2HI  = LOG10(Q2HI)
24590          ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24591       ENDIF
24592
24593       IF ( ELO.EQ. EHI) NEBINS = 0
24594       IF (Q2LO.EQ.Q2HI) NQBINS = 0
24595
24596       WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24597  1000 FORMAT(/,1X,'XSTABL:  E_lo  =',E10.3,' GeV  E_hi  =',E10.3,
24598      &       ' GeV     Lab = ',L1,'  qel: ',I2,/,10X,'Q2_lo =',F10.5,
24599      &       ' GeV^2  Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24600      &       '   A_p = ',I3,'   A_t = ',I3,/)
24601
24602 C     IF (IJPROJ.NE.7) THEN
24603          WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24604 * normalize fractions of emulsion components
24605          IF (NCOMPO.GT.0) THEN
24606             SUMFRA = ZERO
24607             DO 10 I=1,NCOMPO
24608                SUMFRA = SUMFRA+EMUFRA(I)
24609    10       CONTINUE
24610             IF (SUMFRA.GT.ZERO) THEN
24611                DO 11 I=1,NCOMPO
24612                   EMUFRA(I) = EMUFRA(I)/SUMFRA
24613    11          CONTINUE
24614             ENDIF
24615          ENDIF
24616 C     ELSE
24617 C        WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24618 C     ENDIF
24619       DO 1 I=1,NEBINS+1
24620          IF (LELOG) THEN
24621             E = 10**(AELO+DBLE(I-1)*ADEBIN)
24622          ELSE
24623             E = ELO+DBLE(I-1)*DEBINS
24624          ENDIF
24625          DO 2 J=1,NQBINS+1
24626             IF (LQLOG) THEN
24627                Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24628             ELSE
24629                Q2 = Q2LO+DBLE(J-1)*DQBINS
24630             ENDIF
24631 c            IF (IJPROJ.NE.7) THEN
24632                IF (LLAB) THEN
24633                   PLAB = ZERO
24634                   ECM  = ZERO
24635                   CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24636                ELSE
24637                   ECM = E
24638                ENDIF
24639                XI  = ZERO
24640                Q2I = ZERO
24641                IF (IJPROJ.EQ.7) Q2I = Q2
24642                IF (NCOMPO.GT.0) THEN
24643                   DO 20 IC=1,NCOMPO
24644                      IIT = IEMUMA(IC)
24645                      CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24646    20             CONTINUE
24647                ELSE
24648                   CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24649 C                 CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24650                ENDIF
24651                IF (NCOMPO.GT.0) THEN
24652                   XTOT = ZERO
24653                   ETOT = ZERO
24654                   XELA = ZERO
24655                   EELA = ZERO
24656                   XQEP = ZERO
24657                   EQEP = ZERO
24658                   XQET = ZERO
24659                   EQET = ZERO
24660                   XQE2 = ZERO
24661                   EQE2 = ZERO
24662                   XPRO = ZERO
24663                   EPRO = ZERO
24664                   XPRO1= ZERO
24665                   XDEL = ZERO
24666                   EDEL = ZERO
24667                   XDQE = ZERO
24668                   EDQE = ZERO
24669                   DO 21 IC=1,NCOMPO
24670                      XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
24671                      ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
24672                      XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
24673                      EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
24674                      XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
24675                      EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
24676                      XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
24677                      EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
24678                      XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
24679                      EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
24680                      XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
24681                      EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
24682                      XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
24683                      EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
24684                      XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
24685                      EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
24686                      YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
24687      &                     -XSQEP(1,1,IC)-XSQET(1,1,IC)
24688      &                     -XSQE2(1,1,IC)
24689                      XPRO1= XPRO1+EMUFRA(IC)*YPRO
24690    21             CONTINUE
24691                   ETOT = SQRT(ETOT)
24692                   EELA = SQRT(EELA)
24693                   EQEP = SQRT(EQEP)
24694                   EQET = SQRT(EQET)
24695                   EQE2 = SQRT(EQE2)
24696                   EPRO = SQRT(EPRO)
24697                   EDEL = SQRT(EDEL)
24698                   EDQE = SQRT(EDQE)
24699                   WRITE(LOUT,'(8E9.3)')
24700      &               E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
24701 C                 WRITE(LOUT,'(4E9.3)')
24702 C    &               E,XDEL,XDQE,XDEL+XDQE
24703                ELSE
24704                   WRITE(LOUT,'(11E10.3)')
24705      &              E,
24706      &              XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
24707      &              XSQE2(1,1,1),XSPRO(1,1,1),
24708      &              XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
24709      &             -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
24710      &              XSDEL(1,1,1)+XSDQE(1,1,1)
24711 C                 WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
24712 C    &                                    XSDEL(1,1,1)+XSDQE(1,1,1)
24713                ENDIF
24714 c            ELSE
24715 c               IF (LLAB) THEN
24716 c                  IF (IT.GT.1) THEN
24717 c                     IF (IXSQEL.EQ.0) THEN
24718 cC                       CALL DT_SIGGA(IT,  Q2, E,ZERO,ZERO,
24719 cC                       CALL DT_SIGGA(IT,   E,Q2,ZERO,ZERO,
24720 c                        CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
24721 c     &                             STOT,ETOT,SIN,EIN,STOT0)
24722 c                        IF (IRATIO.EQ.1) THEN
24723 c                           CALL DT_SIGGP(  Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
24724 cC                          CALL DT_SIGGP(   E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
24725 cC                          CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
24726 c*!! save cross sections
24727 c                           STOTA = STOT
24728 c                           ETOTA = ETOT
24729 c                           STOTP = STGP
24730 c*!!
24731 c                           STOT  = STOT/(DBLE(IT)*STGP)
24732 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
24733 c                           STOT0 = STGP
24734 c                           ETOT  = ZERO
24735 c                           EIN   = ZERO
24736 c                        ENDIF
24737 c                     ELSE
24738 c                        WRITE(LOUT,*)
24739 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
24740 c                        STOP
24741 c                     ENDIF
24742 c                  ELSE
24743 c                     ETOT = ZERO
24744 c                     EIN  = ZERO
24745 c                     STOT0= ZERO
24746 c                     IF (IXSQEL.EQ.0) THEN
24747 c                        CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
24748 c                     ELSE
24749 c                       SIN = ZERO
24750 c                       CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
24751 c                     ENDIF
24752 c                  ENDIF
24753 c               ELSE
24754 c                  IF (IT.GT.1) THEN
24755 c                     IF (IXSQEL.EQ.0) THEN
24756 c                        CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
24757 c     &                             STOT,ETOT,SIN,EIN,STOT0)
24758 c                        IF (IRATIO.EQ.1) THEN
24759 c                           CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
24760 c*!! save cross sections
24761 c                           STOTA = STOT
24762 c                           ETOTA = ETOT
24763 c                           STOTP = STGP
24764 c*!!
24765 c                           STOT  = STOT/(DBLE(IT)*STGP)
24766 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
24767 c                           STOT0 = STGP
24768 c                           ETOT  = ZERO
24769 c                           EIN   = ZERO
24770 c                        ENDIF
24771 c                     ELSE
24772 c                        WRITE(LOUT,*)
24773 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
24774 c                        STOP
24775 c                     ENDIF
24776 c                  ELSE
24777 c                     ETOT = ZERO
24778 c                     EIN  = ZERO
24779 c                     STOT0= ZERO
24780 c                     IF (IXSQEL.EQ.0) THEN
24781 c                        CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
24782 c                     ELSE
24783 c                       SIN = ZERO
24784 c                       CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
24785 c                     ENDIF
24786 c                  ENDIF
24787 c               ENDIF
24788 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
24789 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
24790 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
24791 c               WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
24792 c            ENDIF
24793     2    CONTINUE
24794     1 CONTINUE
24795
24796       RETURN
24797       END
24798
24799 *$ CREATE DT_TESTXS.FOR
24800 *COPY DT_TESTXS
24801 *
24802 *===testxs=============================================================*
24803 *
24804       SUBROUTINE DT_TESTXS
24805
24806       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24807       SAVE
24808
24809       DIMENSION XSTOT(26,2),XSELA(26,2)
24810
24811       OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
24812       OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
24813       OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
24814       OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
24815       DUMECM = 0.0D0
24816       PLABL = 0.01D0
24817       PLABH = 10000.0D0
24818       NBINS = 120
24819       APLABL = LOG10(PLABL)
24820       APLABH = LOG10(PLABH)
24821       ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
24822       DO 1 I=1,NBINS+1
24823          ADP = APLABL+DBLE(I-1)*ADPLAB
24824          P = 10.0D0**ADP
24825          DO 2 J=1,26
24826             CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
24827             CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
24828     2    CONTINUE
24829          WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
24830          WRITE(11,1000) P,(XSELA(K,1),K=1,26)
24831          WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
24832          WRITE(13,1000) P,(XSELA(K,2),K=1,26)
24833     1 CONTINUE
24834  1000 FORMAT(F8.3,26F9.3)
24835
24836       RETURN
24837       END
24838 ************************************************************************
24839 *                                                                      *
24840 *  DTUNUC 2.0:   library routines                                      *
24841 *                                   processed by S. Roesler, 6.5.95    *
24842 *                                                                      *
24843 ************************************************************************
24844 *
24845 *     1) Handling of parton momenta
24846 *          SUBROUTINE MASHEL
24847 *          SUBROUTINE DFERMI
24848 *
24849 *     2) Handling of parton flavors and particle indices
24850 *          INTEGER FUNCTION IPDG2B
24851 *          INTEGER FUNCTION IB2PDG
24852 *          INTEGER FUNCTION IQUARK
24853 *          INTEGER FUNCTION IBJQUA
24854 *          INTEGER FUNCTION ICIHAD
24855 *          INTEGER FUNCTION IPDGHA
24856 *          INTEGER FUNCTION MCHAD
24857 *          SUBROUTINE FLAHAD
24858 *
24859 *     3) Energy-momentum and quantum number conservation check routines
24860 *          SUBROUTINE EMC1
24861 *          SUBROUTINE EMC2
24862 *          SUBROUTINE EVTEMC
24863 *          SUBROUTINE EVTFLC
24864 *          SUBROUTINE EVTCHG
24865 *
24866 *     4) Transformations
24867 *          SUBROUTINE LTINI
24868 *          SUBROUTINE LTRANS
24869 *          SUBROUTINE LTNUC
24870 *          SUBROUTINE DALTRA
24871 *          SUBROUTINE DTRAFO
24872 *          SUBROUTINE STTRAN
24873 *          SUBROUTINE MYTRAN
24874 *          SUBROUTINE LT2LAO
24875 *          SUBROUTINE LT2LAB
24876 *
24877 *     5) Sampling from distributions
24878 *          INTEGER FUNCTION NPOISS
24879 *          DOUBLE PRECISION FUNCTION SAMPXB
24880 *          DOUBLE PRECISION FUNCTION SAMPEX
24881 *          DOUBLE PRECISION FUNCTION SAMSQX
24882 *          DOUBLE PRECISION FUNCTION BETREJ
24883 *          DOUBLE PRECISION FUNCTION DGAMRN
24884 *          DOUBLE PRECISION FUNCTION DBETAR
24885 *          SUBROUTINE RANNOR
24886 *          SUBROUTINE DPOLI
24887 *          SUBROUTINE DSFECF
24888 *          SUBROUTINE RACO
24889 *
24890 *     6) Special functions, algorithms and service routines
24891 *          DOUBLE PRECISION FUNCTION YLAMB
24892 *          SUBROUTINE SORT
24893 *          SUBROUTINE SORT1
24894 *          SUBROUTINE DT_XTIME
24895 *
24896 *     7) Random number generator package
24897 *          DOUBLE PRECISION FUNCTION DT_RNDM
24898 *          SUBROUTINE DT_RNDMST
24899 *          SUBROUTINE DT_RNDMIN
24900 *          SUBROUTINE DT_RNDMOU
24901 *          SUBROUTINE DT_RNDMTE
24902 *
24903 ************************************************************************
24904 *                                                                      *
24905 *                 1) Handling of parton momenta                        *
24906 *                                                                      *
24907 ************************************************************************
24908 *$ CREATE DT_MASHEL.FOR
24909 *COPY DT_MASHEL
24910 *
24911 *===mashel=============================================================*
24912 *
24913       SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
24914
24915 ************************************************************************
24916 *                                                                      *
24917 *    rescaling of momenta of two partons to put both                   *
24918 *                                       on mass shell                  *
24919 *                                                                      *
24920 *    input:       PA1,PA2   input momentum vectors                     *
24921 *                 XM1,2     desired masses of particles afterwards     *
24922 *                 P1,P2     changed momentum vectors                   *
24923 *                                                                      *
24924 * The original version is written by R. Engel.                         *
24925 * This version dated 12.12.94 is modified by S. Roesler.               *
24926 ************************************************************************
24927
24928       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24929       SAVE
24930
24931       PARAMETER ( LINP = 10 ,
24932      &            LOUT = 6 ,
24933      &            LDAT = 9 )
24934
24935       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
24936
24937       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
24938
24939       IREJ = 0
24940
24941 * Lorentz transformation into system CMS
24942       PX  = PA1(1)+PA2(1)
24943       PY  = PA1(2)+PA2(2)
24944       PZ  = PA1(3)+PA2(3)
24945       EE  = PA1(4)+PA2(4)
24946       XPTOT = SQRT(PX**2+PY**2+PZ**2)
24947       XMS   = (EE-XPTOT)*(EE+XPTOT)
24948       IF(XMS.LT.(XM1+XM2)**2) THEN
24949 C        WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
24950          GOTO 9999
24951       ENDIF
24952       XMS = SQRT(XMS)
24953       BGX = PX/XMS
24954       BGY = PY/XMS
24955       BGZ = PZ/XMS
24956       GAM = EE/XMS
24957       CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
24958      &           PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
24959 * rotation angles
24960       COD = P1(3)/PTOT1
24961 C     SID = SQRT((ONE-COD)*(ONE+COD))
24962       PPT = SQRT(P1(1)**2+P1(2)**2)
24963       SID = PPT/PTOT1
24964       COF = ONE
24965       SIF = ZERO
24966       IF(PTOT1*SID.GT.TINY10) THEN
24967          COF   = P1(1)/(SID*PTOT1)
24968          SIF   = P1(2)/(SID*PTOT1)
24969          ANORF = SQRT(COF*COF+SIF*SIF)
24970          COF   = COF/ANORF
24971          SIF   = SIF/ANORF
24972       ENDIF
24973 * new CM momentum and energies (for masses XM1,XM2)
24974       XM12 = SIGN(XM1**2,XM1)
24975       XM22 = SIGN(XM2**2,XM2)
24976       SS   = XMS**2
24977       PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
24978       EE1  = SQRT(XM12+PCMP**2)
24979       EE2  = XMS-EE1
24980 * back rotation
24981       MODE = 1
24982       CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
24983       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
24984      &            PTOT1,P1(1),P1(2),P1(3),P1(4))
24985       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
24986      &            PTOT2,P2(1),P2(2),P2(3),P2(4))
24987 * check consistency
24988       DEL = XMS*0.0001D0
24989       IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
24990         IDEV = 1
24991       ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
24992         IDEV = 2
24993       ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
24994         IDEV = 3
24995       ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
24996         IDEV = 4
24997       ELSE
24998         IDEV = 0
24999       ENDIF
25000       IF (IDEV.NE.0) THEN
25001          WRITE(LOUT,'(/1X,A,I3)')
25002      &      'MASHEL: inconsistent transformation',IDEV
25003          WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25004          WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25005          WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25006          WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25007          WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25008          WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25009       ENDIF
25010       RETURN
25011
25012  9999 CONTINUE
25013       IREJ = 1
25014       RETURN
25015       END
25016
25017 *$ CREATE DT_DFERMI.FOR
25018 *COPY DT_DFERMI
25019 *
25020 *===dfermi=============================================================*
25021 *
25022       SUBROUTINE DT_DFERMI(GPART)
25023
25024 ************************************************************************
25025 * Find largest of three random numbers.                                *
25026 ************************************************************************
25027
25028       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25029       SAVE
25030
25031       DIMENSION G(3)
25032
25033       DO 10 I=1,3
25034         G(I)=DT_RNDM(GPART)
25035    10 CONTINUE
25036       IF (G(3).LT.G(2)) GOTO 40
25037       IF (G(3).LT.G(1)) GOTO 30
25038       GPART = G(3)
25039    20 RETURN
25040    30 GPART = G(1)
25041       GOTO 20
25042    40 IF (G(2).LT.G(1)) GOTO 30
25043       GPART = G(2)
25044       GOTO 20
25045
25046       END
25047
25048 ************************************************************************
25049 *                                                                      *
25050 *         2) Handling of parton flavors and particle indices           *
25051 *                                                                      *
25052 ************************************************************************
25053 *$ CREATE IDT_IPDG2B.FOR
25054 *COPY IDT_IPDG2B
25055 *
25056 *===ipdg2b=============================================================*
25057 *
25058       INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25059
25060 ************************************************************************
25061 *                                                                      *
25062 *     conversion of quark numbering scheme                             *
25063 *                                                                      *
25064 *     input:   PDG parton numbering                                    *
25065 *              for diquarks:  NN number of the constituent quark       *
25066 *                             (e.g. ID=2301,NN=1 -> ICONV2=1)          *
25067 *                                                                      *
25068 *     output:  BAMJET particle codes                                   *
25069 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25070 *              2 d     8 a-d             -2 a-d                        *
25071 *              3 s     9 a-s             -3 a-s                        *
25072 *              4 c    10 a-c             -4 a-c                        *
25073 *                                                                      *
25074 * This is a modified version of ICONV2 written by R. Engel.            *
25075 * This version dated 13.12.94 is written by S. Roesler.                *
25076 ************************************************************************
25077
25078       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25079       SAVE
25080
25081       PARAMETER ( LINP = 10 ,
25082      &            LOUT = 6 ,
25083      &            LDAT = 9 )
25084
25085       IDA = ABS(ID)
25086 * diquarks
25087       IF (IDA.GT.6) THEN
25088         KF  = 3
25089         IF (IDA.GE.1000) KF = 4
25090         IDA = IDA/(10**(KF-NN))
25091         IDA = MOD(IDA,10)
25092       ENDIF
25093 * exchange up and dn quarks
25094       IF (IDA.EQ.1) THEN
25095         IDA = 2
25096       ELSEIF (IDA.EQ.2) THEN
25097         IDA = 1
25098       ENDIF
25099 * antiquarks
25100       IF (ID.LT.0) THEN
25101          IF (MODE.EQ.1) THEN
25102             IDA = IDA+6
25103          ELSE
25104             IDA = -IDA
25105          ENDIF
25106       ENDIF
25107       IDT_IPDG2B = IDA
25108
25109       RETURN
25110       END
25111
25112 *$ CREATE IDT_IB2PDG.FOR
25113 *COPY IDT_IB2PDG
25114 *
25115 *===ib2pdg=============================================================*
25116 *
25117       INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25118
25119 ************************************************************************
25120 *                                                                      *
25121 *     conversion of quark numbering scheme                             *
25122 *                                                                      *
25123 *     input:   BAMJET particle codes                                   *
25124 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25125 *              2 d     8 a-d             -2 a-d                        *
25126 *              3 s     9 a-s             -3 a-s                        *
25127 *              4 c    10 a-c             -4 a-c                        *
25128 *                                                                      *
25129 *     output:  PDG parton numbering                                    *
25130 *                                                                      *
25131 * This version dated 13.12.94 is written by S. Roesler.                *
25132 ************************************************************************
25133
25134       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25135       SAVE
25136
25137       PARAMETER ( LINP = 10 ,
25138      &            LOUT = 6 ,
25139      &            LDAT = 9 )
25140
25141       DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25142       DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25143       DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25144      &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25145      &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25146
25147       IDA = ID1
25148       IDB = ID2
25149       IF (MODE.EQ.1) THEN
25150          IF (ID1.GT.6) IDA = -(ID1-6)
25151          IF (ID2.GT.6) IDB = -(ID2-6)
25152       ENDIF
25153       IF (ID2.EQ.0) THEN
25154          IDT_IB2PDG = IHKKQ(IDA)
25155       ELSE
25156          IDT_IB2PDG = IHKKQQ(IDA,IDB)
25157       ENDIF
25158
25159       RETURN
25160       END
25161
25162 *$ CREATE IDT_IQUARK.FOR
25163 *COPY IDT_IQUARK
25164 *
25165 *===ipdgqu=============================================================*
25166 *
25167       INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25168
25169 ************************************************************************
25170 *                                                                      *
25171 *     quark contents according to PDG conventions                      *
25172 *     (random selection in case of quark mixing)                       *
25173 *                                                                      *
25174 *     input:   IDBAMJ BAMJET particle code                             *
25175 *              K      1..3   quark number                              *
25176 *                                                                      *
25177 *     output:  1   d  (anti --> neg.)                                  *
25178 *              2   u                                                   *
25179 *              3   s                                                   *
25180 *              4   c                                                   *
25181 *                                                                      *
25182 * This version written by R. Engel.                                    *
25183 ************************************************************************
25184
25185       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25186       SAVE
25187
25188       IQ = IDT_IBJQUA(K,IDBAMJ)
25189 * quark-antiquark
25190       IF (IQ.GT.6) THEN
25191          IQ = 6-IQ
25192       ENDIF
25193 * exchange of up and down
25194       IF (ABS(IQ).EQ.1) THEN
25195          IQ = SIGN(2,IQ)
25196       ELSEIF (ABS(IQ).EQ.2) THEN
25197          IQ = SIGN(1,IQ)
25198       ENDIF
25199       IDT_IQUARK = IQ
25200
25201       RETURN
25202       END
25203
25204 *$ CREATE IDT_IBJQUA.FOR
25205 *COPY IDT_IBJQUA
25206 *
25207 *===ibamq==============================================================*
25208 *
25209       INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25210
25211 ************************************************************************
25212 *                                                                      *
25213 *     quark contents according to BAMJET conventions                   *
25214 *     (random selection in case of quark mixing)                       *
25215 *                                                                      *
25216 *     input:   IDBAMJ BAMJET particle code                             *
25217 *              K      1..3   quark number                              *
25218 *                                                                      *
25219 *     output:  1   u      7   u bar                                    *
25220 *              2   d      8   d bar                                    *
25221 *              3   s      9   s bar                                    *
25222 *              4   c     10   c bar                                    *
25223 *                                                                      *
25224 * This version written by R. Engel.                                    *
25225 ************************************************************************
25226
25227       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25228       SAVE
25229
25230       DIMENSION ITAB(3,210)
25231       DATA ((ITAB(I,K),I=1,3),K=1,30) /
25232      &    1,  1,  2,   7,  7,  8,   0,  0,  0,
25233      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25234      &    0,  0,  0,   1,  2,  2,   7,  8,  8,
25235 *sr 10.1.94
25236 C    &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25237      &    0,  0,  0,   0,  0,  0,   3,  8,  0,
25238 *
25239      &    1,  8,  0,   2,  7,  0,   1,  9,  0,
25240 *sr 10.1.94
25241 C    &    3,  7,  0,   0,  0,  0,   0,  0,  0,
25242      &    3,  7,  0,   3,  1,  2,   9,  7,  8,
25243 *sr 10.1.94
25244 C    &    0,  0,  0,   2,  2,  3,   1,  1,  3,
25245      &    2,  9,  0,   2,  2,  3,   1,  1,  3,
25246 *
25247      &    1,  2,  3, 201,202,  0,   2,  9,  0,
25248      &    3,  8,  0,   0,  0,  0,   0,  0,  0,
25249      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25250       DATA ((ITAB(I,K),I=1,3),K=31,60) /
25251      &    3,  9,  0,   1,  8,  0, 203,204,  0,
25252      &    2,  7,  0,   0,  0,  0,   1,  9,  0,
25253      &    2,  9,  0,   3,  7,  0,   3,  8,  0,
25254      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25255      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25256      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25257      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25258      &    0,  0,  0,   1,  1,  1,   1,  1,  2,
25259      &    1,  2,  2,   2,  2,  2,   0,  0,  0,
25260      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25261       DATA ((ITAB(I,K),I=1,3),K=61,90) /
25262      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25263      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25264      &    7,  7,  7,   7,  7,  8,   7,  8,  8,
25265      &    8,  8,  8,   0,  0,  0,   0,  0,  0,
25266      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25267      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25268      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25269      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25270      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25271      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25272       DATA ((ITAB(I,K),I=1,3),K=91,120) /
25273      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25274      &    0,  0,  0,   0,  0,  0,   3,  9,  0,
25275      &    1,  3,  3,   2,  3,  3,   7,  7,  9,
25276      &    7,  8,  9,   8,  8,  9,   7,  9,  9,
25277      &    8,  9,  9,   1,  1,  3,   1,  2,  3,
25278      &    2,  2,  3,   1,  3,  3,   2,  3,  3,
25279      &    3,  3,  3,   7,  7,  9,   7,  8,  9,
25280      &    8,  8,  9,   7,  9,  9,   8,  9,  9,
25281      &    9,  9,  9,   4,  7,  0,   4,  8,  0,
25282      &    2, 10,  0,   1, 10,  0,   4,  9,  0 /
25283       DATA ((ITAB(I,K),I=1,3),K=121,150) /
25284      &    3, 10,  0,   4, 10,  0,   4,  7,  0,
25285      &    4,  8,  0,   2, 10,  0,   1, 10,  0,
25286      &    4,  9,  0,   3, 10,  0,   4, 10,  0,
25287      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25288      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25289      &    0,  0,  0,   1,  2,  4,   1,  3,  4,
25290      &    2,  3,  4,   1,  1,  4,   0,  0,  0,
25291      &    2,  2,  4,   0,  0,  0,   0,  0,  0,
25292      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25293      &    3,  4,  4,   7,  8, 10,   7,  9, 10 /
25294       DATA ((ITAB(I,K),I=1,3),K=151,180) /
25295      &    8,  9, 10,   7,  7, 10,   0,  0,  0,
25296      &    8,  8, 10,   0,  0,  0,   0,  0,  0,
25297      &    9,  9, 10,   7, 10, 10,   8, 10, 10,
25298      &    9, 10, 10,   1,  1,  4,   1,  2,  4,
25299      &    2,  2,  4,   1,  3,  4,   2,  3,  4,
25300      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25301      &    3,  4,  4,   4,  4,  4,   7,  7, 10,
25302      &    7,  8, 10,   8,  8, 10,   7,  9, 10,
25303      &    8,  9, 10,   9,  9, 10,   7, 10, 10,
25304      &    8, 10, 10,   9, 10, 10,  10, 10, 10 /
25305       DATA ((ITAB(I,K),I=1,3),K=181,210) /
25306      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25307      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25308      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25309      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25310      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25311      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25312      &    0,  0,  0,   0,  0,  0,   1,  7,  0,
25313      &    2,  8,  0,   1,  7,  0,   2,  8,  0,
25314      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25315      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25316       DATA IDOLD /0/
25317
25318       ONE = 1.0D0
25319       IF (ITAB(1,IDBAMJ).LE.200) THEN
25320          ID = ITAB(K,IDBAMJ)
25321       ELSE
25322          IF(IDOLD.NE.IDBAMJ) THEN
25323             IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25324      &           DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25325         ELSE
25326            IDOLD = 0
25327         ENDIF
25328         ID = ITAB(K,IT)
25329       ENDIF
25330       IDOLD  = IDBAMJ
25331       IDT_IBJQUA = ID
25332
25333       RETURN
25334       END
25335
25336 *$ CREATE IDT_ICIHAD.FOR
25337 *COPY IDT_ICIHAD
25338 *
25339 *===icihad=============================================================*
25340 *
25341       INTEGER FUNCTION IDT_ICIHAD(MCIND)
25342
25343 ************************************************************************
25344 * Conversion of particle index PDG proposal --> BAMJET-index scheme    *
25345 * This is a completely new version dated 25.10.95.                     *
25346 * Renamed to be not in conflict with the modified PHOJET-version       *
25347 ************************************************************************
25348
25349       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25350       SAVE
25351
25352 * hadron index conversion (BAMJET <--> PDG)
25353       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25354      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25355      &                IAMCIN(210)
25356
25357       IDT_ICIHAD = 0
25358       KPDG   = ABS(MCIND)
25359       IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25360       IF (MCIND.LT.0) THEN
25361          JSIGN = 1
25362       ELSE
25363          JSIGN = 2
25364       ENDIF
25365       IF (KPDG.GE.10000) THEN
25366          DO 1 I=1,19
25367             IDT_ICIHAD = IBAM5(JSIGN,I)
25368             IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25369             IDT_ICIHAD = 0
25370     1    CONTINUE
25371       ELSEIF (KPDG.GE.1000) THEN
25372          DO 2 I=1,29
25373             IDT_ICIHAD = IBAM4(JSIGN,I)
25374             IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25375             IDT_ICIHAD = 0
25376     2    CONTINUE
25377       ELSEIF (KPDG.GE.100) THEN
25378          DO 3 I=1,22
25379             IDT_ICIHAD = IBAM3(JSIGN,I)
25380             IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25381             IDT_ICIHAD = 0
25382     3    CONTINUE
25383       ELSEIF (KPDG.GE.10) THEN
25384          DO 4 I=1,7
25385             IDT_ICIHAD = IBAM2(JSIGN,I)
25386             IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25387             IDT_ICIHAD = 0
25388     4    CONTINUE
25389       ENDIF
25390     5 CONTINUE
25391
25392       RETURN
25393       END
25394
25395 *$ CREATE IDT_IPDGHA.FOR
25396 *COPY IDT_IPDGHA
25397 *
25398 *===ipdgha=============================================================*
25399 *
25400       INTEGER FUNCTION IDT_IPDGHA(MCIND)
25401
25402 ************************************************************************
25403 * Conversion of particle index BAMJET-index scheme --> PDG proposal    *
25404 * Adopted from the original by S. Roesler. This version dated 12.5.95  *
25405 * Renamed to be not in conflict with the modified PHOJET-version       *
25406 ************************************************************************
25407
25408       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25409       SAVE
25410
25411 * hadron index conversion (BAMJET <--> PDG)
25412       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25413      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25414      &                IAMCIN(210)
25415
25416       IDT_IPDGHA = IAMCIN(MCIND)
25417
25418       RETURN
25419       END
25420
25421 *$ CREATE DT_FLAHAD.FOR
25422 *COPY DT_FLAHAD
25423 *
25424 *===flahad=============================================================*
25425 *
25426       SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25427
25428 ************************************************************************
25429 * sampling of FLAvor composition for HADrons/photons                   *
25430 *              ID         BAMJET-id of hadron                          *
25431 *              IF1,2,3    flavor content                               *
25432 *                         (u,d,s: 1,2,3;  au,ad,as: -1,-1,-3)          *
25433 * Note:  -  u,d numbering as in BAMJET                                 *
25434 *        -  ID .le. 30 !!                                              *
25435 * This version dated 12.03.96 is written by S. Roesler                 *
25436 ************************************************************************
25437
25438       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25439       SAVE
25440
25441 * auxiliary common for reggeon exchange (DTUNUC 1.x)
25442       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25443      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25444      &                IQTCHR(-6:6),MQUARK(3,39)
25445
25446       DIMENSION JSEL(3,6)
25447       DATA JSEL/ 1,2,3,  2,3,1,  3,1,2,  1,3,2,   2,1,3,   3,2,1/
25448
25449       ONE = 1.0D0
25450       IF (ID.EQ.7) THEN
25451 * photon (charge dependent flavour sampling)
25452          K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25453          IF (K.LE.4) THEN
25454             IF1 = 2
25455             IF2 = -2
25456          ELSE IF(K.EQ.5) THEN
25457             IF1 = 1
25458             IF2 = -1
25459          ELSE
25460             IF1 = 3
25461             IF2 = -3
25462          ENDIF
25463          IF(DT_RNDM(ONE).LT.0.5D0) THEN
25464             K   = IF1
25465             IF1 = IF2
25466             IF2 = K
25467          ENDIF
25468          IF3 = 0
25469       ELSE
25470 * hadron
25471          IX  = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25472          IF1 = MQUARK(JSEL(1,IX),ID)
25473          IF2 = MQUARK(JSEL(2,IX),ID)
25474          IF3 = MQUARK(JSEL(3,IX),ID)
25475          IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25476             IF1 = IF3
25477             IF3 = 0
25478          ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25479             IF2 = IF3
25480             IF3 = 0
25481          ENDIF
25482       ENDIF
25483
25484       RETURN
25485       END
25486
25487 *$ CREATE IDT_MCHAD.FOR
25488 *COPY IDT_MCHAD
25489 *
25490 *===mchad==============================================================*
25491 *
25492       INTEGER FUNCTION IDT_MCHAD(ITDTU)
25493
25494 ************************************************************************
25495 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25496 * Adopted from the original by S. Roesler. This version dated 6.5.95   *
25497 *                                                                      *
25498 * Last change 28.12.2006 by S. Roesler.                                *
25499 ************************************************************************
25500
25501       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25502       SAVE
25503
25504       DIMENSION ITRANS(210)
25505       DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25506      &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25507      &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25508      &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25509      &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25510      &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25511      &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25512
25513       IF ( ITDTU .GT. 0 ) THEN
25514          IDT_MCHAD = ITRANS(ITDTU)
25515       ELSE
25516          IDT_MCHAD = -1
25517       END IF
25518
25519       RETURN
25520       END
25521
25522 ************************************************************************
25523 *                                                                      *
25524 *   3) Energy-momentum and quantum number conservation check routines  *
25525 *                                                                      *
25526 ************************************************************************
25527 *$ CREATE DT_EMC1.FOR
25528 *COPY DT_EMC1
25529 *
25530 *===emc1===============================================================*
25531 *
25532       SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25533
25534 ************************************************************************
25535 * This version dated 15.12.94 is written by S. Roesler                 *
25536 ************************************************************************
25537
25538       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25539       SAVE
25540
25541       PARAMETER ( LINP = 10 ,
25542      &            LOUT = 6 ,
25543      &            LDAT = 9 )
25544
25545       PARAMETER (TINY10=1.0D-10)
25546
25547       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25548
25549       IREJ = 0
25550
25551       IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25552      &   WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25553
25554       IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25555          IF (MODE.EQ.1) THEN
25556             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25557          ELSEIF (MODE.EQ.2) THEN
25558             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25559          ENDIF
25560          CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25561          CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25562          CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25563       ELSEIF (MODE.LT.0) THEN
25564          IF (MODE.EQ.-1) THEN
25565             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25566          ELSEIF (MODE.EQ.-2) THEN
25567             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25568          ENDIF
25569          CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25570          CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25571          CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25572       ENDIF
25573
25574       IF (ABS(MODE).EQ.3) THEN
25575          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25576          IF (IREJ1.NE.0) GOTO 9999
25577       ENDIF
25578       RETURN
25579
25580  9999 CONTINUE
25581       IREJ = 1
25582       RETURN
25583       END
25584
25585 *$ CREATE DT_EMC2.FOR
25586 *COPY DT_EMC2
25587 *
25588 *===emc2===============================================================*
25589 *
25590       SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25591      &                                                MODE,IPOS,IREJ)
25592
25593 ************************************************************************
25594 *             MODE = 1   energy-momentum cons. check                   *
25595 *                  = 2   flavor-cons. check                            *
25596 *                  = 3   energy-momentum & flavor cons. check          *
25597 *                  = 4   energy-momentum & charge cons. check          *
25598 *                  = 5   energy-momentum & flavor & charge cons. check *
25599 * This version dated 16.01.95 is written by S. Roesler                 *
25600 ************************************************************************
25601
25602       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25603       SAVE
25604
25605       PARAMETER ( LINP = 10 ,
25606      &            LOUT = 6 ,
25607      &            LDAT = 9 )
25608
25609       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25610
25611 * event history
25612
25613       PARAMETER (NMXHKK=200000)
25614
25615       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25616      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25617      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25618
25619 * extended event history
25620       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25621      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25622      &                IHIST(2,NMXHKK)
25623
25624       IREJ  = 0
25625       IREJ1 = 0
25626       IREJ2 = 0
25627       IREJ3 = 0
25628
25629       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25630      &                CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25631       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25632      &                                CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25633       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25634       DO 1 I=1,NHKK
25635          IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25636      &       (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25637      &       (ISTHKK(I).EQ.IP5))                          THEN
25638             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25639      &                                    .OR.(MODE.EQ.5))
25640      &      CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25641      &                                               2,IDUM,IDUM)
25642             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25643      &         CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25644             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25645      &                            CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25646          ENDIF
25647          IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25648      &       (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25649      &       (ISTHKK(I).EQ.IN5))                          THEN
25650             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25651      &                                    .OR.(MODE.EQ.5))
25652      &      CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25653      &                                                   2,IDUM,IDUM)
25654             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25655      &         CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25656             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25657      &                            CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25658          ENDIF
25659     1 CONTINUE
25660       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25661      &   CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25662       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25663      &   CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25664       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25665       IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25666
25667       RETURN
25668
25669  9999 CONTINUE
25670       IREJ = 1
25671       RETURN
25672       END
25673
25674 *$ CREATE DT_EVTEMC.FOR
25675 *COPY DT_EVTEMC
25676 *
25677 *===evtemc=============================================================*
25678 *
25679       SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
25680
25681 ************************************************************************
25682 * This version dated 13.12.94 is written by S. Roesler                 *
25683 ************************************************************************
25684
25685       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25686       SAVE
25687
25688       PARAMETER ( LINP = 10 ,
25689      &            LOUT = 6 ,
25690      &            LDAT = 9 )
25691
25692       PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
25693      &           ZERO=0.0D0)
25694
25695 * event history
25696
25697       PARAMETER (NMXHKK=200000)
25698
25699       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25700      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25701      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25702
25703 * flags for input different options
25704       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
25705       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
25706      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
25707
25708       IREJ = 0
25709
25710       MODE = IMODE
25711       CHKLEV = TINY10
25712       IF (MODE.EQ.4) THEN
25713          CHKLEV = TINY2
25714          MODE   = 3
25715       ELSEIF (MODE.EQ.5) THEN
25716          CHKLEV = TINY1
25717          MODE   = 3
25718       ELSEIF (MODE.EQ.-1) THEN
25719          CHKLEV = EIO
25720          MODE   = 3
25721       ENDIF
25722
25723       IF (ABS(MODE).EQ.3) THEN
25724          PXDEV = PX
25725          PYDEV = PY
25726          PZDEV = PZ
25727          EDEV  = E
25728          IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
25729          IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
25730      &       (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
25731             IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
25732      &         'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
25733      &         '  event  ',NEVHKK,
25734      &         ' ! ',PXDEV,PYDEV,PZDEV,EDEV
25735             PX   = 0.0D0
25736             PY   = 0.0D0
25737             PZ   = 0.0D0
25738             E    = 0.0D0
25739             GOTO 9999
25740          ENDIF
25741          PX   = 0.0D0
25742          PY   = 0.0D0
25743          PZ   = 0.0D0
25744          E    = 0.0D0
25745          RETURN
25746       ENDIF
25747
25748       IF (MODE.EQ.1) THEN
25749          PX = 0.0D0
25750          PY = 0.0D0
25751          PZ = 0.0D0
25752          E  = 0.0D0
25753       ENDIF
25754
25755       PX = PX+PXIO
25756       PY = PY+PYIO
25757       PZ = PZ+PZIO
25758       E  = E+EIO
25759
25760       RETURN
25761
25762  9999 CONTINUE
25763       IREJ = 1
25764       RETURN
25765       END
25766
25767 *$ CREATE DT_EVTFLC.FOR
25768 *COPY DT_EVTFLC
25769 *
25770 *===evtflc=============================================================*
25771 *
25772       SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
25773
25774 ************************************************************************
25775 * Flavor conservation check.                                           *
25776 *        ID       identity of particle                                 *
25777 *        ID1 = 1  ID for q,aq,qq,aqaq in PDG-numbering scheme          *
25778 *            = 2  ID for particle/resonance in BAMJET numbering scheme *
25779 *            = 3  ID for particle/resonance in PDG    numbering scheme *
25780 *        MODE = 1 initialization and add ID                            *
25781 *             =-1 initialization and subtract ID                       *
25782 *             = 2 add ID                                               *
25783 *             =-2 subtract ID                                          *
25784 *             = 3 check flavor cons.                                   *
25785 *        IPOS     flag to give position of call of EVTFLC to output    *
25786 *                 unit in case of violation                            *
25787 * This version dated 10.01.95 is written by S. Roesler                 *
25788 ************************************************************************
25789
25790       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25791       SAVE
25792
25793       PARAMETER ( LINP = 10 ,
25794      &            LOUT = 6 ,
25795      &            LDAT = 9 )
25796
25797       PARAMETER (TINY10=1.0D-10)
25798
25799       IREJ = 0
25800
25801       IF (MODE.EQ.3) THEN
25802          IF (IFL.NE.0) THEN
25803             WRITE(LOUT,'(1X,A,I3,A,I3)')
25804      &         'EVTFLC: flavor-conservation failure at pos. ',IPOS,
25805      &         ' !  IFL = ',IFL
25806             IFL = 0
25807             GOTO 9999
25808          ENDIF
25809          IFL = 0
25810          RETURN
25811       ENDIF
25812
25813       IF (MODE.EQ.1) IFL = 0
25814       IF (ID.EQ.0)   RETURN
25815
25816       IF (ID1.EQ.1) THEN
25817          IDD = ABS(ID)
25818          NQ  = 1
25819          IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
25820          IF (IDD.GE.1000) NQ = 3
25821          DO 1 I=1,NQ
25822             IFBAM = IDT_IPDG2B(ID,I,2)
25823             IF (ABS(IFBAM).EQ.1) THEN
25824                IFBAM = SIGN(2,IFBAM)
25825             ELSEIF (ABS(IFBAM).EQ.2) THEN
25826                IFBAM = SIGN(1,IFBAM)
25827             ENDIF
25828             IF (MODE.GT.0) THEN
25829                IFL = IFL+IFBAM
25830             ELSE
25831                IFL = IFL-IFBAM
25832             ENDIF
25833     1    CONTINUE
25834          RETURN
25835       ENDIF
25836
25837       IDD = ID
25838       IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
25839       IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
25840          DO 2 I=1,3
25841             IF (MODE.GT.0) THEN
25842                IFL = IFL+IDT_IQUARK(I,IDD)
25843             ELSE
25844                IFL = IFL-IDT_IQUARK(I,IDD)
25845             ENDIF
25846     2    CONTINUE
25847       ENDIF
25848       RETURN
25849
25850  9999 CONTINUE
25851       IREJ = 1
25852       RETURN
25853       END
25854
25855 *$ CREATE DT_EVTCHG.FOR
25856 *COPY DT_EVTCHG
25857 *
25858 *===evtchg=============================================================*
25859 *
25860       SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
25861
25862 ************************************************************************
25863 * Charge conservation check.                                           *
25864 *        ID       identity of particle (PDG-numbering scheme)          *
25865 *        MODE = 1 initialization                                       *
25866 *             =-2 subtract ID-charge                                   *
25867 *             = 2 add ID-charge                                        *
25868 *             = 3 check charge cons.                                   *
25869 *        IPOS     flag to give position of call of EVTCHG to output    *
25870 *                 unit in case of violation                            *
25871 * This version dated 10.01.95 is written by S. Roesler                 *
25872 * Last change: s.r. 21.01.01                                           *
25873 ************************************************************************
25874
25875       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25876       SAVE
25877
25878       PARAMETER ( LINP = 10 ,
25879      &            LOUT = 6 ,
25880      &            LDAT = 9 )
25881
25882 * event history
25883
25884       PARAMETER (NMXHKK=200000)
25885
25886       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25887      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25888      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25889
25890 * particle properties (BAMJET index convention)
25891       CHARACTER*8  ANAME
25892       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
25893      &                IICH(210),IIBAR(210),K1(210),K2(210)
25894
25895       IREJ = 0
25896
25897       IF (MODE.EQ.1) THEN
25898          ICH  = 0
25899          IBAR = 0
25900          RETURN
25901       ENDIF
25902
25903       IF (MODE.EQ.3) THEN
25904          IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
25905             WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
25906      &         'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
25907      &         '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
25908             ICH  = 0
25909             IBAR = 0
25910             GOTO 9999
25911          ENDIF
25912          ICH  = 0
25913          IBAR = 0
25914          RETURN
25915       ENDIF
25916
25917       IF (ID.EQ.0)   RETURN
25918
25919       IDD = IDT_ICIHAD(ID)
25920 * modification 21.1.01: use intrinsic phojet-functions to determine charge
25921 * and baryon number
25922 C     IF (IDD.GT.0) THEN
25923 C        IF (MODE.EQ.2) THEN
25924 C           ICH  = ICH+IICH(IDD)
25925 C           IBAR = IBAR+IIBAR(IDD)
25926 C        ELSEIF (MODE.EQ.-2) THEN
25927 C           ICH  = ICH-IICH(IDD)
25928 C           IBAR = IBAR-IIBAR(IDD)
25929 C        ENDIF
25930 C     ELSE
25931 C        WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
25932 C        CALL DT_EVTOUT(4)
25933 C        STOP
25934 C     ENDIF
25935       IF (MODE.EQ.2) THEN
25936          ICH  = ICH+IPHO_CHR3(ID,1)/3
25937          IBAR = IBAR+IPHO_BAR3(ID,1)/3
25938       ELSEIF (MODE.EQ.-2) THEN
25939          ICH  = ICH-IPHO_CHR3(ID,1)/3
25940          IBAR = IBAR-IPHO_BAR3(ID,1)/3
25941       ENDIF
25942
25943       RETURN
25944
25945  9999 CONTINUE
25946       IREJ = 1
25947       RETURN
25948       END
25949
25950 ************************************************************************
25951 *                                                                      *
25952 *                 4) Transformations                                   *
25953 *                                                                      *
25954 ************************************************************************
25955 *$ CREATE DT_LTINI.FOR
25956 *COPY DT_LTINI
25957 *
25958 *===ltini==============================================================*
25959 *
25960       SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
25961
25962 ************************************************************************
25963 * Initializations of Lorentz-transformations, calculation of Lorentz-  *
25964 * parameters.                                                          *
25965 * This version dated 13.11.95 is written by  S. Roesler.               *
25966 ************************************************************************
25967
25968       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25969       SAVE
25970
25971       PARAMETER ( LINP = 10 ,
25972      &            LOUT = 6 ,
25973      &            LDAT = 9 )
25974
25975       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
25976      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
25977
25978 * Lorentz-parameters of the current interaction
25979       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
25980      &                UMO,PPCM,EPROJ,PPROJ
25981
25982 * properties of photon/lepton projectiles
25983       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
25984
25985 * particle properties (BAMJET index convention)
25986       CHARACTER*8  ANAME
25987       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
25988      &                IICH(210),IIBAR(210),K1(210),K2(210)
25989
25990 * nucleon-nucleon event-generator
25991       CHARACTER*8 CMODEL
25992       LOGICAL LPHOIN
25993       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
25994
25995       Q2   = VIRT
25996       IDP  = IDPR
25997       IF (MCGENE.NE.3) THEN
25998 * lepton-projectiles and PHOJET: initialize real photon instead
25999          IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26000      &       (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26001      &       (IDPR.EQ. 5).OR.(IDPR.EQ. 6))   THEN
26002             IDP = 7
26003             Q2  = ZERO
26004          ENDIF
26005       ENDIF
26006       IDT  = IDTA
26007       EPN  = EPN0
26008       PPN  = PPN0
26009       ECM  = ECM0
26010       AMP  = AAM(IDP)-SQRT(ABS(Q2))
26011       AMT  = AAM(IDT)
26012       AMP2 = SIGN(AMP**2,AMP)
26013       AMT2 = AMT**2
26014       IF (ECM0.GT.ZERO) THEN
26015          EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26016          IF (AMP2.GT.ZERO) THEN
26017             PPN = SQRT((EPN+AMP)*(EPN-AMP))
26018          ELSE
26019             PPN = SQRT(EPN**2-AMP2)
26020          ENDIF
26021       ELSE
26022          IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26023             IF (IDP.EQ.7) EPN = ABS(EPN)
26024             IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26025             IF (AMP2.GT.ZERO) THEN
26026                PPN = SQRT((EPN+AMP)*(EPN-AMP))
26027             ELSE
26028                PPN = SQRT(EPN**2-AMP2)
26029             ENDIF
26030          ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26031             IF (AMP2.GT.ZERO) THEN
26032                EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26033             ELSE
26034                EPN = SQRT(PPN**2+AMP2)
26035             ENDIF
26036          ENDIF
26037          ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26038       ENDIF
26039       UMO   = ECM
26040       EPROJ = EPN
26041       PPROJ = PPN
26042       IF (AMP2.GT.ZERO) THEN
26043          ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26044          PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26045       ELSE
26046          ETARG = TINY10
26047          PTARG = TINY10
26048       ENDIF
26049 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26050       IF (IDP.EQ.7) THEN
26051          PGAMM(1) = ZERO
26052          PGAMM(2) = ZERO
26053          AMGAM  = AMP
26054          AMGAM2 = AMP2
26055          IF (ECM0.GT.ZERO) THEN
26056             S = ECM0**2
26057          ELSE
26058             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26059                S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26060             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26061                S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26062             ENDIF
26063          ENDIF
26064          PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26065      &                     +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26066          PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26067          IF (MODE.EQ.1) THEN
26068             PNUCL(1) = ZERO
26069             PNUCL(2) = ZERO
26070             PNUCL(3) = -PGAMM(3)
26071             PNUCL(4) = SQRT(S)-PGAMM(4)
26072          ENDIF
26073       ENDIF
26074       IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26075      &    (IDPR.EQ.10).OR.(IDPR.EQ.11))   THEN
26076          PLEPT0(1) = ZERO
26077          PLEPT0(2) = ZERO
26078 * neglect lepton masses
26079 C        AMLPT2   = AAM(IDPR)**2
26080          AMLPT2   = ZERO
26081 *
26082          IF (ECM0.GT.ZERO) THEN
26083             S = ECM0**2
26084          ELSE
26085             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26086                S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26087             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26088                S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26089             ENDIF
26090          ENDIF
26091          PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26092      &                     +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26093          PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26094          PNUCL(1) = ZERO
26095          PNUCL(2) = ZERO
26096          PNUCL(3) = -PLEPT0(3)
26097          PNUCL(4) = SQRT(S)-PLEPT0(4)
26098       ENDIF
26099 * Lorentz-parameter for transformation Lab. - projectile rest system
26100       IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26101          GALAB = TINY10
26102          BGLAB = TINY10
26103          BLAB  = TINY10
26104       ELSE
26105          GALAB = EPROJ/AMP
26106          BGLAB = PPROJ/AMP
26107          BLAB  = BGLAB/GALAB
26108       ENDIF
26109 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26110       IF (IDP.EQ.7) THEN
26111          GACMS(1) = TINY10
26112          BGCMS(1) = TINY10
26113       ELSE
26114          GACMS(1) = (ETARG+AMP)/UMO
26115          BGCMS(1) = PTARG/UMO
26116       ENDIF
26117 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26118       GACMS(2) = (EPROJ+AMT)/UMO
26119       BGCMS(2) = PPROJ/UMO
26120       PPCM     = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26121
26122       EPN0 = EPN
26123       PPN0 = PPN
26124       ECM0 = ECM
26125
26126       RETURN
26127       END
26128
26129 *$ CREATE DT_LTRANS.FOR
26130 *COPY DT_LTRANS
26131 *
26132 *===ltrans=============================================================*
26133 *
26134       SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26135
26136 ************************************************************************
26137 * Lorentz-transformations.                                             *
26138 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26139 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26140 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26141 * This version dated 01.11.95 is written by  S. Roesler.               *
26142 ************************************************************************
26143
26144       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26145       SAVE
26146
26147       PARAMETER ( LINP = 10 ,
26148      &            LOUT = 6 ,
26149      &            LDAT = 9 )
26150
26151       PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26152
26153       PARAMETER (SQTINF=1.0D+15)
26154
26155 * particle properties (BAMJET index convention)
26156       CHARACTER*8  ANAME
26157       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26158      &                IICH(210),IIBAR(210),K1(210),K2(210)
26159
26160       PXO = PXI
26161       PYO = PYI
26162       CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26163
26164 * check particle mass for consistency (numerical rounding errors)
26165       PO     = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26166       AMO2   = (PEO-PO)*(PEO+PO)
26167       AMORQ2 = AAM(ID)**2
26168       AMDIF2 = ABS(AMO2-AMORQ2)
26169       IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26170          DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26171          PEO   = PEO+DELTA
26172          PO1   = PO -DELTA
26173          PXO   = PXO*PO1/PO
26174          PYO   = PYO*PO1/PO
26175          PZO   = PZO*PO1/PO
26176 C        WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26177       ENDIF
26178
26179       RETURN
26180       END
26181
26182 *$ CREATE DT_LTNUC.FOR
26183 *COPY DT_LTNUC
26184 *
26185 *===ltnuc==============================================================*
26186 *
26187       SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26188
26189 ************************************************************************
26190 * Lorentz-transformations.                                             *
26191 *   PIN        longitudnal momentum       (input)                      *
26192 *   EIN        energy                     (input)                      *
26193 *   POUT       transformed long. momentum (output)                     *
26194 *   EOUT       transformed energy         (output)                     *
26195 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26196 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26197 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26198 * This version dated 01.11.95 is written by  S. Roesler.               *
26199 ************************************************************************
26200
26201       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26202       SAVE
26203
26204       PARAMETER ( LINP = 10 ,
26205      &            LOUT = 6 ,
26206      &            LDAT = 9 )
26207
26208       PARAMETER (ZERO=0.0D0)
26209
26210 * Lorentz-parameters of the current interaction
26211       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26212      &                UMO,PPCM,EPROJ,PPROJ
26213
26214       BDUM1 = ZERO
26215       BDUM2 = ZERO
26216       PDUM1 = ZERO
26217       PDUM2 = ZERO
26218       IF (ABS(MODE).EQ.1) THEN
26219          BG = -SIGN(BGLAB,DBLE(MODE))
26220          CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26221      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26222       ELSEIF (ABS(MODE).EQ.2) THEN
26223          BG = SIGN(BGCMS(1),DBLE(MODE))
26224          CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26225      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26226       ELSEIF (ABS(MODE).EQ.3) THEN
26227          BG = -SIGN(BGCMS(2),DBLE(MODE))
26228          CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26229      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26230       ELSE
26231          WRITE(LOUT,1000) MODE
26232  1000    FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26233          EOUT = EIN
26234          POUT = PIN
26235       ENDIF
26236
26237       RETURN
26238       END
26239
26240 *$ CREATE DT_DALTRA.FOR
26241 *COPY DT_DALTRA
26242 *
26243 *===daltra=============================================================*
26244 *
26245       SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26246
26247 ************************************************************************
26248 * Arbitrary Lorentz-transformation.                                    *
26249 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
26250 ************************************************************************
26251
26252       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26253       SAVE
26254       PARAMETER (ONE=1.0D0)
26255
26256       EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26257       PE = EP/(GA+ONE)+EC
26258       PX = PCX+BGX*PE
26259       PY = PCY+BGY*PE
26260       PZ = PCZ+BGZ*PE
26261       P  = SQRT(PX*PX+PY*PY+PZ*PZ)
26262       E  = GA*EC+EP
26263
26264       RETURN
26265       END
26266
26267 *$ CREATE DT_DTRAFO.FOR
26268 *COPY DT_DTRAFO
26269 *
26270 *====dtrafo============================================================*
26271 *
26272       SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26273      &                                    PL,CXL,CYL,CZL,EL)
26274
26275 C     LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26276
26277       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26278       SAVE
26279
26280       IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26281       SID  = SQRT(1.D0-COD*COD)
26282       PLX  = P*SID*COF
26283       PLY  = P*SID*SIF
26284       PCMZ = P*COD
26285       PLZ  = GAM*PCMZ+BGAM*ECM
26286       PL   = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26287       EL   = GAM*ECM+BGAM*PCMZ
26288 C     ROTATION INTO THE ORIGINAL DIRECTION
26289       COZ  = PLZ/PL
26290       SIZ  = SQRT(1.D0-COZ**2)
26291       CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26292
26293       RETURN
26294       END
26295
26296 *$ CREATE DT_STTRAN.FOR
26297 *COPY DT_STTRAN
26298 *
26299 *====sttran============================================================*
26300 *
26301       SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26302
26303       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26304       SAVE
26305       DATA ANGLSQ/1.D-30/
26306 ************************************************************************
26307 *     VERSION BY                     J. RANFT                          *
26308 *                                    LEIPZIG                           *
26309 *                                                                      *
26310 *     THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES      *
26311 *                                                                      *
26312 *     INPUT VARIABLES:                                                 *
26313 *        XO,YO,ZO = ORIGINAL DIRECTION COSINES                         *
26314 *        CDE,SDE  = COSINE AND SINE OF THE POLAR (THETA)               *
26315 *                   ANGLE OF "SCATTERING"                              *
26316 *        SDE      = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING"    *
26317 *        SFE,CFE  = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE       *
26318 *                   OF "SCATTERING"                                    *
26319 *                                                                      *
26320 *     OUTPUT VARIABLES:                                                *
26321 *        X,Y,Z     = NEW DIRECTION COSINES                             *
26322 *                                                                      *
26323 *     ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 )                  *
26324 ************************************************************************
26325 *
26326 *
26327 *  Changed by A. Ferrari
26328 *
26329 *     IF (ABS(XO)-0.0001D0) 1,1,2
26330 *   1 IF (ABS(YO)-0.0001D0) 3,3,2
26331 *   3 CONTINUE
26332       A = XO**2 + YO**2
26333       IF ( A .LT. ANGLSQ ) THEN
26334          X=SDE*CFE
26335          Y=SDE*SFE
26336          Z=CDE*ZO
26337       ELSE
26338          XI=SDE*CFE
26339          YI=SDE*SFE
26340          ZI=CDE
26341          A=SQRT(A)
26342          X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26343          Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26344          Z=A*YI+ZO*ZI
26345       ENDIF
26346
26347       RETURN
26348       END
26349
26350 *$ CREATE DT_MYTRAN.FOR
26351 *COPY DT_MYTRAN
26352 *
26353 *===mytran=============================================================*
26354 *
26355       SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26356
26357 ************************************************************************
26358 * This subroutine rotates the coordinate frame                         *
26359 *    a) theta  around y                                                *
26360 *    b) phi    around z      if IMODE = 1                              *
26361 *                                                                      *
26362 *     x'          cos(ph) -sin(ph) 0      cos(th)  0  sin(th)   x      *
26363 *     y' = A B =  sin(ph) cos(ph)  0  .   0        1        0   y      *
26364 *     z'          0       0        1     -sin(th)  0  cos(th)   z      *
26365 *                                                                      *
26366 * and vice versa if IMODE = 0.                                         *
26367 * This version dated 5.4.94 is based on the original version DTRAN     *
26368 * by J. Ranft and is written by S. Roesler.                            *
26369 ************************************************************************
26370
26371       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26372       SAVE
26373
26374       PARAMETER ( LINP = 10 ,
26375      &            LOUT = 6 ,
26376      &            LDAT = 9 )
26377
26378       IF (IMODE.EQ.1) THEN
26379          X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26380          Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26381          Z=-SDE    *XO       +CDE    *ZO
26382       ELSE
26383          X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26384          Y= -SFE*XO+CFE*YO
26385          Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26386       ENDIF
26387       RETURN
26388       END
26389
26390 *$ CREATE DT_LT2LAO.FOR
26391 *COPY DT_LT2LAO
26392 *
26393 *===lt2lab=============================================================*
26394 *
26395       SUBROUTINE DT_LT2LAO
26396
26397 ************************************************************************
26398 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26399 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26400 * and transforms them back to the lab.                                 *
26401 * This version dated 16.11.95 is written by S. Roesler                 *
26402 ************************************************************************
26403
26404       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26405       SAVE
26406
26407       PARAMETER ( LINP = 10 ,
26408      &            LOUT = 6 ,
26409      &            LDAT = 9 )
26410
26411 * event history
26412
26413       PARAMETER (NMXHKK=200000)
26414
26415       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26416      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26417      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26418
26419 * extended event history
26420       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26421      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26422      &                IHIST(2,NMXHKK)
26423
26424       NEND      = NHKK
26425       NPOINT(5) = NHKK+1
26426       IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26427       DO 1 I=NPOINT(4),NEND
26428 C     DO 1 I=1,NEND
26429          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26430      &                                (ISTHKK(I).EQ.1001)) THEN
26431             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26432             NOB = NOBAM(I)
26433             CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26434      &                            PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26435             IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26436                ISTHKK(I) = 3*ISTHKK(I)
26437                NOBAM(NHKK)  = NOB
26438             ELSE
26439                IF (ISTHKK(I).EQ.-1) NOBAM(NHKK)  = NOB
26440                ISTHKK(I) = SIGN(3,ISTHKK(I))
26441             ENDIF
26442             JDAHKK(1,I) = NHKK
26443          ENDIF
26444     1 CONTINUE
26445
26446       RETURN
26447       END
26448
26449 *$ CREATE DT_LT2LAB.FOR
26450 *COPY DT_LT2LAB
26451 *
26452 *===lt2lab=============================================================*
26453 *
26454       SUBROUTINE DT_LT2LAB
26455
26456 ************************************************************************
26457 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26458 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26459 * and transforms them to the lab.                                      *
26460 * This version dated 07.01.96 is written by S. Roesler                 *
26461 ************************************************************************
26462
26463       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26464       SAVE
26465
26466       PARAMETER ( LINP = 10 ,
26467      &            LOUT = 6 ,
26468      &            LDAT = 9 )
26469
26470 * event history
26471
26472       PARAMETER (NMXHKK=200000)
26473
26474       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26475      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26476      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26477
26478 * extended event history
26479       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26480      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26481      &                IHIST(2,NMXHKK)
26482
26483       IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26484       DO 1 I=NPOINT(4),NHKK
26485          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26486      &                                (ISTHKK(I).EQ.1001)) THEN
26487             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26488             PHKK(3,I) = PZ
26489             PHKK(4,I) = PE
26490          ENDIF
26491     1 CONTINUE
26492
26493       RETURN
26494       END
26495
26496 ************************************************************************
26497 *                                                                      *
26498 *                 5) Sampling from distributions                       *
26499 *                                                                      *
26500 ************************************************************************
26501 *$ CREATE IDT_NPOISS.FOR
26502 *COPY IDT_NPOISS
26503 *
26504 *===npoiss=============================================================*
26505 *
26506       INTEGER FUNCTION IDT_NPOISS(AVN)
26507
26508 ************************************************************************
26509 * Sample according to Poisson distribution with Poisson parameter AVN. *
26510 * The original version written by J. Ranft.                            *
26511 * This version dated 11.1.95 is written by S. Roesler.                 *
26512 ************************************************************************
26513
26514       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26515       SAVE
26516
26517       PARAMETER ( LINP = 10 ,
26518      &            LOUT = 6 ,
26519      &            LDAT = 9 )
26520
26521       EXPAVN = EXP(-AVN)
26522       K = 1
26523       A = 1.0D0
26524
26525    10 CONTINUE
26526       A = DT_RNDM(A)*A
26527       IF (A.GE.EXPAVN) THEN
26528          K = K+1
26529          GOTO 10
26530       ENDIF
26531       IDT_NPOISS = K-1
26532
26533       RETURN
26534       END
26535
26536 *$ CREATE DT_SAMPXB.FOR
26537 *COPY DT_SAMPXB
26538 *
26539 *===sampxb=============================================================*
26540 *
26541       DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26542
26543 ************************************************************************
26544 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2.             *
26545 * Processed by S. Roesler, 6.5.95                                      *
26546 ************************************************************************
26547
26548       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26549       SAVE
26550       PARAMETER (TWO=2.0D0)
26551
26552       A1 = LOG(X1+SQRT(X1**2+B**2))
26553       A2 = LOG(X2+SQRT(X2**2+B**2))
26554       AN = A2-A1
26555       A  = AN*DT_RNDM(A1)+A1
26556       BB = EXP(A)
26557       DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26558
26559       RETURN
26560       END
26561
26562 *$ CREATE DT_SAMPEX.FOR
26563 *COPY DT_SAMPEX
26564 *
26565 *===sampex=============================================================*
26566 *
26567       DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26568
26569 ************************************************************************
26570 * Sampling from f(x)=1./x between x1 and x2.                           *
26571 * Processed by S. Roesler, 6.5.95                                      *
26572 ************************************************************************
26573
26574       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26575       SAVE
26576       PARAMETER (ONE=1.0D0)
26577
26578       R   = DT_RNDM(X1)
26579       AL1 = LOG(X1)
26580       AL2 = LOG(X2)
26581       DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26582
26583       RETURN
26584       END
26585
26586 *$ CREATE DT_SAMSQX.FOR
26587 *COPY DT_SAMSQX
26588 *
26589 *===samsqx=============================================================*
26590 *
26591       DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26592
26593 ************************************************************************
26594 * Sampling from f(x)=1./x^0.5 between x1 and x2.                       *
26595 * Processed by S. Roesler, 6.5.95                                      *
26596 ************************************************************************
26597
26598       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26599       SAVE
26600       PARAMETER (ONE=1.0D0)
26601
26602       R = DT_RNDM(X1)
26603       DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26604
26605       RETURN
26606       END
26607
26608 *$ CREATE DT_SAMPLW.FOR
26609 *COPY DT_SAMPLW
26610 *
26611 *===samplw=============================================================*
26612 *
26613       DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26614
26615 ************************************************************************
26616 * Sampling from f(x)=1/x^b between x_min and x_max.                    *
26617 * S. Roesler, 18.4.98                                                  *
26618 ************************************************************************
26619
26620       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26621       SAVE
26622       PARAMETER (ONE=1.0D0)
26623
26624       R = DT_RNDM(B)
26625       IF (B.EQ.ONE) THEN
26626          DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26627       ELSE
26628          ONEMB  = ONE-B
26629          DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26630       ENDIF
26631
26632       RETURN
26633       END
26634
26635 *$ CREATE DT_BETREJ.FOR
26636 *COPY DT_BETREJ
26637 *
26638 *===betrej=============================================================*
26639 *
26640       DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26641
26642       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26643       SAVE
26644
26645       PARAMETER ( LINP = 10 ,
26646      &            LOUT = 6 ,
26647      &            LDAT = 9 )
26648
26649       PARAMETER (ONE=1.0D0)
26650
26651       IF (XMIN.GE.XMAX)THEN
26652          WRITE (LOUT,500) XMIN,XMAX
26653   500    FORMAT(1X,'DT_BETREJ:  XMIN<XMAX execution stopped ',2F10.5)
26654          STOP
26655       ENDIF
26656
26657    10 CONTINUE
26658       XX     = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26659       BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26660       YY     = BETMAX*DT_RNDM(XX)
26661       BETXX  = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26662       IF (YY.GT.BETXX) GOTO 10
26663       DT_BETREJ = XX
26664
26665       RETURN
26666       END
26667
26668 *$ CREATE DT_DGAMRN.FOR
26669 *COPY DT_DGAMRN
26670 *
26671 *===dgamrn=============================================================*
26672 *
26673       DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26674
26675 ************************************************************************
26676 * Sampling from Gamma-distribution.                                    *
26677 *       F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)            *
26678 * Processed by S. Roesler, 6.5.95                                      *
26679 ************************************************************************
26680
26681       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26682       SAVE
26683       PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26684
26685       NCOU = 0
26686       N    = INT(ETA)
26687       F    = ETA-DBLE(N)
26688       IF (F.EQ.ZERO) GOTO 20
26689    10 R = DT_RNDM(F)
26690       NCOU = NCOU+1
26691       IF (NCOU.GE.11) GOTO 20
26692       IF (R.LT.F/(F+2.71828D0)) GOTO 30
26693       YYY = LOG(DT_RNDM(R)+TINY9)/F
26694       IF (ABS(YYY).GT.50.0D0) GOTO 20
26695       Y = EXP(YYY)
26696       IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26697       GOTO 40
26698    20 Y = 0.0D0
26699       GOTO 50
26700    30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26701       IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
26702    40 IF (N.EQ.0) GOTO 70
26703    50 Z = 1.0D0
26704       DO 60 I = 1,N
26705    60 Z = Z*DT_RNDM(Z)
26706       Y = Y-LOG(Z+TINY9)
26707    70 DT_DGAMRN = Y/ALAM
26708
26709       RETURN
26710       END
26711
26712 *$ CREATE DT_DBETAR.FOR
26713 *COPY DT_DBETAR
26714 *
26715 *===dbetar=============================================================*
26716 *
26717       DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
26718
26719 ************************************************************************
26720 * Sampling from Beta -distribution between 0.0 and 1.0                 *
26721 *  F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
26722 * Processed by S. Roesler, 6.5.95                                      *
26723 ************************************************************************
26724
26725       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26726       SAVE
26727
26728       Y = DT_DGAMRN(1.0D0,GAM)
26729       Z = DT_DGAMRN(1.0D0,ETA)
26730       DT_DBETAR = Y/(Y+Z)
26731
26732       RETURN
26733       END
26734
26735 *$ CREATE DT_RANNOR.FOR
26736 *COPY DT_RANNOR
26737 *
26738 *===rannor=============================================================*
26739 *
26740       SUBROUTINE DT_RANNOR(X,Y)
26741
26742 ************************************************************************
26743 * Sampling from Gaussian distribution.                                 *
26744 * Processed by S. Roesler, 6.5.95                                      *
26745 ************************************************************************
26746
26747       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26748       SAVE
26749       PARAMETER (TINY10=1.0D-10)
26750
26751       CALL DT_DSFECF(SFE,CFE)
26752       V = MAX(TINY10,DT_RNDM(X))
26753       A = SQRT(-2.D0*LOG(V))
26754       X = A*SFE
26755       Y = A*CFE
26756
26757       RETURN
26758       END
26759
26760 *$ CREATE DT_DPOLI.FOR
26761 *COPY DT_DPOLI
26762 *
26763 *===dpoli==============================================================*
26764 *
26765       SUBROUTINE DT_DPOLI(CS,SI)
26766
26767       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26768       SAVE
26769
26770       U  = DT_RNDM(CS)
26771       CS = DT_RNDM(U)
26772       IF (U.LT.0.5D0) CS=-CS
26773       SI = SQRT(1.0D0-CS*CS+1.0D-10)
26774
26775       RETURN
26776       END
26777
26778 *$ CREATE DT_DSFECF.FOR
26779 *COPY DT_DSFECF
26780 *
26781 *===dsfecf=============================================================*
26782 *
26783       SUBROUTINE DT_DSFECF(SFE,CFE)
26784
26785       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26786       SAVE
26787       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26788
26789     1 CONTINUE
26790       X  = DT_RNDM(SFE)
26791       Y  = DT_RNDM(X)
26792       XX = X*X
26793       YY = Y*Y
26794       XY = XX+YY
26795       IF (XY.GT.ONE) GOTO 1
26796       CFE = (XX-YY)/XY
26797       SFE = TWO*X*Y/XY
26798       IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
26799       RETURN
26800       END
26801
26802 *$ CREATE DT_RACO.FOR
26803 *COPY DT_RACO
26804 *
26805 *===raco===============================================================*
26806 *
26807       SUBROUTINE DT_RACO(WX,WY,WZ)
26808
26809 ************************************************************************
26810 * Direction cosines of random uniform (isotropic) direction in three   *
26811 * dimensional space                                                    *
26812 * Processed by S. Roesler, 20.11.95                                    *
26813 ************************************************************************
26814
26815       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26816       SAVE
26817       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26818
26819   10  CONTINUE
26820       X  = TWO*DT_RNDM(WX)-ONE
26821       Y  = DT_RNDM(X)
26822       X2 = X*X
26823       Y2 = Y*Y
26824       IF (X2+Y2.GT.ONE) GOTO 10
26825
26826       CFE = (X2-Y2)/(X2+Y2)
26827       SFE = TWO*X*Y/(X2+Y2)
26828 * z = 1/2 [ 1 + cos (theta) ]
26829       Z   = DT_RNDM(X)
26830 * 1/2 sin (theta)
26831       WZ = SQRT(Z*(ONE-Z))
26832       WX = TWO*WZ*CFE
26833       WY = TWO*WZ*SFE
26834       WZ = TWO*Z-ONE
26835
26836       RETURN
26837       END
26838
26839 ************************************************************************
26840 *                                                                      *
26841 *           6) Special functions, algorithms and service routines      *
26842 *                                                                      *
26843 ************************************************************************
26844 *$ CREATE DT_YLAMB.FOR
26845 *COPY DT_YLAMB
26846 *
26847 *===ylamb==============================================================*
26848 *
26849       DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
26850
26851 ************************************************************************
26852 *                                                                      *
26853 *     auxiliary function for three particle decay mode                 *
26854 *     (standard LAMBDA**(1/2) function)                                *
26855 *                                                                      *
26856 * Adopted from an original version written by R. Engel.                *
26857 * This version dated 12.12.94 is written by S. Roesler.                *
26858 ************************************************************************
26859
26860       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26861       SAVE
26862
26863       YZ   = Y-Z
26864       XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
26865       IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
26866       DT_YLAMB = SQRT(XLAM)
26867
26868       RETURN
26869       END
26870
26871 *$ CREATE DT_SORT.FOR
26872 *COPY DT_SORT
26873 *
26874 *===sort1==============================================================*
26875 *
26876       SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
26877
26878 ************************************************************************
26879 * This subroutine sorts entries in A in increasing/decreasing order    *
26880 * of A(3,i).                                                           *
26881 *              MODE  = 1     increasing in A(3,i=1..N)                 *
26882 *                    = 2     decreasing in A(3,i=1..N)                 *
26883 * This version dated 21.04.95 is revised by S. Roesler                 *
26884 ************************************************************************
26885
26886       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26887       SAVE
26888
26889       DIMENSION A(3,N)
26890
26891       M = I1
26892    10 CONTINUE
26893       M = I1-1
26894       IF (M.LE.0) RETURN
26895       L = 0
26896       DO 20 I=I0,M
26897          J = I+1
26898          IF (MODE.EQ.1) THEN
26899             IF (A(3,I).LE.A(3,J)) GOTO 20
26900          ELSE
26901             IF (A(3,I).GE.A(3,J)) GOTO 20
26902          ENDIF
26903          B = A(3,I)
26904          C = A(1,I)
26905          D = A(2,I)
26906          A(3,I) = A(3,J)
26907          A(2,I) = A(2,J)
26908          A(1,I) = A(1,J)
26909          A(3,J) = B
26910          A(1,J) = C
26911          A(2,J) = D
26912          L = 1
26913    20 CONTINUE
26914       IF (L.EQ.1) GOTO 10
26915
26916       RETURN
26917       END
26918
26919 *$ CREATE DT_SORT1.FOR
26920 *COPY DT_SORT1
26921 *
26922 *===sort1==============================================================*
26923 *
26924       SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
26925
26926 ************************************************************************
26927 * This subroutine sorts entries in A in increasing/decreasing order    *
26928 * of A(i).                                                             *
26929 *              MODE  = 1     increasing in A(i=1..N)                   *
26930 *                    = 2     decreasing in A(i=1..N)                   *
26931 * This version dated 21.04.95 is revised by S. Roesler                 *
26932 ************************************************************************
26933
26934       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26935       SAVE
26936
26937       DIMENSION A(N),IDX(N)
26938
26939       M = I1
26940    10 CONTINUE
26941       M = I1-1
26942       IF (M.LE.0) RETURN
26943       L = 0
26944       DO 20 I=I0,M
26945          J = I+1
26946          IF (MODE.EQ.1) THEN
26947             IF (A(I).LE.A(J)) GOTO 20
26948          ELSE
26949             IF (A(I).GE.A(J)) GOTO 20
26950          ENDIF
26951          B    = A(I)
26952          A(I) = A(J)
26953          A(J) = B
26954          IX     = IDX(I)
26955          IDX(I) = IDX(J)
26956          IDX(J) = IX
26957          L = 1
26958    20 CONTINUE
26959       IF (L.EQ.1) GOTO 10
26960
26961       RETURN
26962       END
26963
26964 *$ CREATE DT_XTIME.FOR
26965 *COPY DT_XTIME
26966 *
26967 *===xtime==============================================================*
26968 *
26969       SUBROUTINE DT_XTIME
26970
26971       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26972       SAVE
26973
26974       PARAMETER ( LINP = 10 ,
26975      &            LOUT = 6 ,
26976      &            LDAT = 9 )
26977
26978       CHARACTER DAT*9,TIM*11
26979
26980       DAT = '         '
26981       TIM = '           '
26982 C     CALL GETDAT(IYEAR,IMONTH,IDAY)
26983 C     CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
26984
26985 C     CALL DATE(DAT)
26986 C     CALL TIME(TIM)
26987 C     WRITE(LOUT,1000) DAT,TIM
26988  1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
26989
26990       RETURN
26991       END
26992
26993 ************************************************************************
26994 *                                                                      *
26995 *                 7) Random number generator package                   *
26996 *                                                                      *
26997 *    THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND        *
26998 *    SERVICE ROUTINES.                                                 *
26999 *    THE ALGORITHM IS FROM                                             *
27000 *      'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR'                     *
27001 *      G.MARSAGLIA, A.ZAMAN ;  FSU-SCRI-87-50                          *
27002 *    IMPLEMENTATION BY K. HAHN  DEC. 88,                               *
27003 *    THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27004 *    AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ),        *
27005 *    THE PERIOD IS ABOUT 2**144,                                       *
27006 *    TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS,            *
27007 *    THE PACKAGE CONTAINS                                              *
27008 *      FUNCTION DT_RNDM(I)                  : GENERATOR                *
27009 *      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION           *
27010 *      SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)  : PUT SEED TO GENERATOR    *
27011 *      SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)  : TAKE SEED FROM GENERATOR *
27012 *      SUBROUTINE DT_RNDMTE(IO)             : TEST OF GENERATOR        *
27013 *---                                                                   *
27014 *    FUNCTION DT_RNDM(I)                                               *
27015 *       GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS  IN (0..1)          *
27016 *       I  - DUMMY VARIABLE, NOT USED                                  *
27017 *    SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)                             *
27018 *       INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27019 *       NA1,NA2,NA3,NB1  - VALUES FOR INITIALIZING THE GENERATOR       *
27020 *                          NA? MUST BE IN 1..178 AND NOT ALL 1         *
27021 *                          12,34,56  ARE THE STANDARD VALUES           *
27022 *                          NB1 MUST BE IN 1..168                       *
27023 *                          78  IS THE STANDARD VALUE                   *
27024 *    SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)                               *
27025 *       PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS   *
27026 *       AS AFTER THE LAST DT_RNDMOU CALL )                             *
27027 *       U(97),C,CD,CM,I,J  - SEED VALUES AS TAKEN FROM DT_RNDMOU       *
27028 *    SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)                               *
27029 *       TAKES SEED FROM GENERATOR                                      *
27030 *       U(97),C,CD,CM,I,J  - SEED VALUES                               *
27031 *    SUBROUTINE DT_RNDMTE(IO)                                          *
27032 *       TEST OF THE GENERATOR                                          *
27033 *       IO     - DEFINES OUTPUT                                        *
27034 *                  = 0  OUTPUT ONLY IF AN ERROR IS DETECTED            *
27035 *                  = 1  OUTPUT INDEPENDEND ON AN ERROR                 *
27036 *       DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO   *
27037 *       SAME STATUS                                                    *
27038 *       AS BEFORE CALL OF DT_RNDMTE                                    *
27039 ************************************************************************
27040 *$ CREATE DT_RNDM.FOR
27041 *COPY DT_RNDM
27042 *
27043 *===rndm===============================================================*
27044 *
27045 c$$$      DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27046 c$$$
27047 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27048 c$$$      SAVE
27049 c$$$
27050 c$$$* counter of calls to random number generator
27051 c$$$* uncomment if needed
27052 c$$$C     COMMON /DTRNCT/ IRNCT0,IRNCT1
27053 c$$$C     LOGICAL LFIRST
27054 c$$$C     DATA LFIRST /.TRUE./
27055 c$$$
27056 c$$$* counter of calls to random number generator
27057 c$$$* uncomment if needed
27058 c$$$C     IF (LFIRST) THEN
27059 c$$$C        IRNCT0 = 0
27060 c$$$C        IRNCT1 = 0
27061 c$$$C        LFIRST = .FALSE.
27062 c$$$C     ENDIF
27063 c$$$
27064 c$$$      DT_RNDM = FLRNDM(VDUMMY)
27065 c$$$* counter of calls to random number generator
27066 c$$$* uncomment if needed
27067 c$$$C     IRNCT1 = IRNCT1+1
27068 c$$$
27069 c$$$      RETURN
27070 c$$$      END
27071 c$$$
27072 c$$$*$ CREATE DT_RNDMST.FOR
27073 c$$$*COPY DT_RNDMST
27074 c$$$*
27075 c$$$*===rndmst=============================================================*
27076 c$$$*
27077 c$$$      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27078 c$$$
27079 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27080 c$$$      SAVE
27081 c$$$
27082 c$$$* random number generator
27083 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27084 c$$$
27085 c$$$      MA1 = NA1
27086 c$$$      MA2 = NA2
27087 c$$$      MA3 = NA3
27088 c$$$      MB1 = NB1
27089 c$$$      I   = 97
27090 c$$$      J   = 33
27091 c$$$      DO 20 II2 = 1,97
27092 c$$$        S = 0
27093 c$$$        T = 0.5D0
27094 c$$$        DO 10 II1 = 1,24
27095 c$$$          MAT  = MOD(MOD(MA1*MA2,179)*MA3,179)
27096 c$$$          MA1  = MA2
27097 c$$$          MA2  = MA3
27098 c$$$          MA3  = MAT
27099 c$$$          MB1  = MOD(53*MB1+1,169)
27100 c$$$          IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27101 c$$$   10   T = 0.5D0*T
27102 c$$$   20 U(II2) = S
27103 c$$$      C  =   362436.0D0/16777216.0D0
27104 c$$$      CD =  7654321.0D0/16777216.0D0
27105 c$$$      CM = 16777213.0D0/16777216.0D0
27106 c$$$      RETURN
27107 c$$$      END
27108 c$$$
27109 c$$$*$ CREATE DT_RNDMIN.FOR
27110 c$$$*COPY DT_RNDMIN
27111 c$$$*
27112 c$$$*===rndmin=============================================================*
27113 c$$$*
27114 c$$$      SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27115 c$$$
27116 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27117 c$$$      SAVE
27118 c$$$
27119 c$$$* random number generator
27120 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27121 c$$$
27122 c$$$      DIMENSION UIN(97)
27123 c$$$
27124 c$$$      DO 10 KKK = 1,97
27125 c$$$   10 U(KKK) = UIN(KKK)
27126 c$$$      C  = CIN
27127 c$$$      CD = CDIN
27128 c$$$      CM = CMIN
27129 c$$$      I  = IIN
27130 c$$$      J  = JIN
27131 c$$$
27132 c$$$      RETURN
27133 c$$$      END
27134 c$$$
27135 c$$$*$ CREATE DT_RNDMOU.FOR
27136 c$$$*COPY DT_RNDMOU
27137 c$$$*
27138 c$$$*===rndmou=============================================================*
27139 c$$$*
27140 c$$$      SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27141 c$$$
27142 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27143 c$$$      SAVE
27144 c$$$
27145 c$$$* random number generator
27146 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27147 c$$$
27148 c$$$      DIMENSION UOUT(97)
27149 c$$$
27150 c$$$      DO 10 KKK = 1,97
27151 c$$$   10 UOUT(KKK) = U(KKK)
27152 c$$$      COUT  = C
27153 c$$$      CDOUT = CD
27154 c$$$      CMOUT = CM
27155 c$$$      IOUT  = I
27156 c$$$      JOUT  = J
27157 c$$$
27158 c$$$      RETURN
27159 c$$$      END
27160 c$$$
27161 c$$$*$ CREATE DT_RNDMTE.FOR
27162 c$$$*COPY DT_RNDMTE
27163 c$$$*
27164 c$$$*===rndmte=============================================================*
27165 c$$$*
27166 c$$$      SUBROUTINE DT_RNDMTE(IO)
27167 c$$$
27168 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27169 c$$$      SAVE
27170 c$$$
27171 c$$$      DIMENSION UU(97),U(6),X(6),D(6)
27172 c$$$      DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27173 c$$$     +8354498.D0, 10633180.D0/
27174 c$$$
27175 c$$$      CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27176 c$$$      CALL DT_RNDMST(12,34,56,78)
27177 c$$$      DO 10 II1 = 1,20000
27178 c$$$   10 XX = DT_RNDM(XX)
27179 c$$$      SD        = 0.0D0
27180 c$$$      DO 20 II2 = 1,6
27181 c$$$        X(II2)  = 4096.D0*(4096.D0*DT_RNDM(SD))
27182 c$$$        D(II2)  = X(II2)-U(II2)
27183 c$$$   20 SD = SD+D(II2)
27184 c$$$      CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27185 c$$$**sr 24.01.95
27186 c$$$C     IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27187 c$$$      IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27188 c$$$C        WRITE(6,1000)
27189 c$$$ 1000    FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27190 c$$$     &          ' passed')
27191 c$$$      ENDIF
27192 c$$$**
27193 c$$$      RETURN
27194 c$$$  500 FORMAT('  === TEST OF THE RANDOM-GENERATOR ===',/,
27195 c$$$     &'    EXPECTED VALUE    CALCULATED VALUE     DIFFERENCE',/, 6(F17.
27196 c$$$     &1,F20.1,F15.3,/), '  === END OF TEST ;',
27197 c$$$     &'  GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27198 c$$$      END
27199 *
27200 *$ CREATE PHO_RNDM.FOR
27201 *COPY PHO_RNDM
27202 *
27203 *===pho_rndm===========================================================*
27204 *
27205       DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27206
27207       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27208       SAVE
27209
27210       PHO_RNDM = DT_RNDM(DUMMY)
27211
27212       RETURN
27213       END
27214
27215 *$ CREATE PYR.FOR
27216 *COPY PYR
27217 *
27218 *===pyr================================================================*
27219 *
27220       DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27221
27222       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27223       SAVE
27224
27225       DUMMY = DBLE(IDUMMY)
27226       PYR = DT_RNDM(DUMMY)
27227
27228       RETURN
27229       END
27230 *$ CREATE DT_TITLE.FOR
27231 *COPY DT_TITLE
27232 *
27233 *===title==============================================================*
27234 *
27235       SUBROUTINE DT_TITLE
27236
27237       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27238       SAVE
27239
27240       PARAMETER ( LINP = 10 ,
27241      &            LOUT = 6 ,
27242      &            LDAT = 9 )
27243
27244       CHARACTER*6 CVERSI
27245       CHARACTER*11 CCHANG
27246       DATA CVERSI,CCHANG /'3.0-5 ','31 Oct 2008'/
27247
27248       CALL DT_XTIME
27249       WRITE(LOUT,1000) CVERSI,CCHANG
27250  1000 FORMAT(1X,'+-------------------------------------------------',
27251      &                  '----------------------+',/,
27252      &     1X,'|',71X,'|',/,
27253      &     1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27254      &     1X,'|',71X,'|',/,
27255      &     1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27256      &     1X,'|',71X,'|',/,
27257      &     1X,'|',12X,'Authors: Stefan Roesler   (CERN)',27X,'|',/,
27258      &     1X,'|',21X,'Ralph Engel      (FZ Karlsruhe)',19X,'|',/,
27259      &     1X,'|',21X,'Johannes Ranft   (Siegen Univ.)',19X,'|',/,
27260 C    &     1X,'|',71X,'|',/,
27261 C    &     1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27262 C    &                                              17X,'|',/,
27263      &     1X,'|',71X,'|',/,
27264      &     1X,'+-------------------------------------------------',
27265      &                '----------------------+',/,
27266      &     1X,'| Please send suggestions, bug reports, etc. to: ',
27267      &                                  'Stefan.Roesler@cern.ch |',/,
27268      &     1X,'+-------------------------------------------------',
27269      &                '----------------------+',/)
27270
27271       RETURN
27272       END
27273
27274 *$ CREATE DT_EVTINI.FOR
27275 *COPY DT_EVTINI
27276 *
27277 *===evtini=============================================================*
27278 *
27279       SUBROUTINE DT_EVTINI
27280
27281 ************************************************************************
27282 * Initialization of DTEVT1.                                            *
27283 * This version dated 15.01.94 is written by S. Roesler                 *
27284 ************************************************************************
27285
27286       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27287       SAVE
27288
27289       PARAMETER ( LINP = 10 ,
27290      &            LOUT = 6 ,
27291      &            LDAT = 9 )
27292
27293 * event history
27294
27295       PARAMETER (NMXHKK=200000)
27296
27297       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27298      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27299      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27300
27301 * extended event history
27302       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27303      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27304      &                IHIST(2,NMXHKK)
27305
27306 * event flag
27307       COMMON /DTEVNO/ NEVENT,ICASCA
27308
27309       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27310
27311 * emulsion treatment
27312       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27313      &                NCOMPO,IEMUL
27314
27315 * initialization of DTEVT1/DTEVT2
27316       NEND = NHKK
27317       IF (NEVENT.EQ.1) NEND = NMXHKK
27318       NHKK   = 0
27319       NEVHKK = NEVENT
27320       DO 1 I=1,NEND
27321          ISTHKK(I)   = 0
27322          IDHKK(I)    = 0
27323          JMOHKK(1,I) = 0
27324          JMOHKK(2,I) = 0
27325          JDAHKK(1,I) = 0
27326          JDAHKK(2,I) = 0
27327          IDRES(I)    = 0
27328          IDXRES(I)   = 0
27329          NOBAM(I)    = 0
27330          IDCH(I)     = 0
27331          IHIST(1,I)  = 0
27332          IHIST(2,I)  = 0
27333          DO 2 J=1,4
27334             PHKK(J,I) = 0.0D0
27335             VHKK(J,I) = 0.0D0
27336             WHKK(J,I) = 0.0D0
27337     2    CONTINUE
27338          PHKK(5,I) = 0.0D0
27339     1 CONTINUE
27340       DO 3 I=1,10
27341          NPOINT(I) = 0
27342     3 CONTINUE
27343       CALL DT_CHASTA(-1)
27344
27345 C* initialization of DTLTRA
27346 C      IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27347
27348       RETURN
27349       END
27350
27351 *$ CREATE DT_STATIS.FOR
27352 *COPY DT_STATIS
27353 *
27354 *===statis=============================================================*
27355 *
27356       SUBROUTINE DT_STATIS(MODE)
27357
27358 ************************************************************************
27359 * Initialization and output of run-statistics.                         *
27360 *              MODE  = 1     initialization                            *
27361 *                    = 2     output                                    *
27362 * This version dated 23.01.94 is written by S. Roesler                 *
27363 ************************************************************************
27364
27365       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27366       SAVE
27367
27368       PARAMETER ( LINP = 10 ,
27369      &            LOUT = 6 ,
27370      &            LDAT = 9 )
27371
27372       PARAMETER (TINY3=1.0D-3)
27373
27374 * statistics
27375       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27376      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27377      &                ICEVTG(8,0:30)
27378
27379 * rejection counter
27380       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27381      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27382      &                IREXCI(3),IRDIFF(2),IRINC
27383
27384 * central particle production, impact parameter biasing
27385       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27386
27387 * various options for treatment of partons (DTUNUC 1.x)
27388 * (chain recombination, Cronin,..)
27389       LOGICAL LCO2CR,LINTPT
27390       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27391      &                LCO2CR,LINTPT
27392
27393 * nucleon-nucleon event-generator
27394       CHARACTER*8 CMODEL
27395       LOGICAL LPHOIN
27396       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27397
27398 * flags for particle decays
27399       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27400      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27401      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27402
27403 * diquark-breaking mechanism
27404       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27405
27406       DIMENSION PP(4),PT(4)
27407
27408       GOTO (1,2) MODE
27409
27410 * initialization
27411     1 CONTINUE
27412
27413 *   initialize statistics counter
27414       ICREQU = 0
27415       ICSAMP = 0
27416       ICCPRO = 0
27417       ICDPR  = 0
27418       ICDTA  = 0
27419       ICRJSS = 0
27420       ICVV2S = 0
27421       DO 10 I=1,9
27422          ICRES(I)    = 0
27423          ICCHAI(1,I) = 0
27424          ICCHAI(2,I) = 0
27425    10 CONTINUE
27426 *   initialize rejection counter
27427       IRPT      = 0
27428       IRHHA     = 0
27429       LOMRES    = 0
27430       LOBRES    = 0
27431       IRFRAG    = 0
27432       IREVT     = 0
27433       IRRES(1)  = 0
27434       IRRES(2)  = 0
27435       IRCHKI(1) = 0
27436       IRCHKI(2) = 0
27437       IRCRON(1) = 0
27438       IRCRON(2) = 0
27439       IRCRON(3) = 0
27440       IRDIFF(1) = 0
27441       IRDIFF(2) = 0
27442       IRINC     = 0
27443       DO 11 I=1,5
27444          ICDIFF(I) = 0
27445    11 CONTINUE
27446       DO 12 I=1,8
27447          DO 13 J=0,30
27448             ICEVTG(I,J) = 0
27449    13    CONTINUE
27450    12 CONTINUE
27451
27452       RETURN
27453
27454 * output
27455     2 CONTINUE
27456
27457 *   statistics counter
27458       WRITE(LOUT,1000)
27459  1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27460      &       28X,'---------------------')
27461       IF (ICREQU.GT.0) THEN
27462       WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27463  1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27464      &       I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27465      &       'event',11X,F9.1)
27466       ENDIF
27467       IF (ICDIFF(1).NE.0) THEN
27468          WRITE(LOUT,1009) ICDIFF
27469  1009    FORMAT(/,1X,'diffractive events:    total   ',I8,/,49X,
27470      &          'low mass   high mass',/,24X,'single diffraction',
27471      &          7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27472       ENDIF
27473       IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
27474          WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27475      &                    DBLE(ICSAMP)/DBLE(ICCPRO)
27476  1002    FORMAT(/,1X,'central production:',/,2X,'mean number',
27477      &          ' of sampled Glauber-events per event',9X,F9.1,/,
27478      &          2X,'fraction of production cross section',21X,F10.6)
27479       ENDIF
27480       IF (ICSAMP.GT.0) THEN
27481       WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27482      &                 DBLE(ICDTA)/DBLE(ICSAMP)
27483  1003 FORMAT(/,54X,'proj.    targ.',/,1X,'average number of wounded',
27484      &       ' nucleons after x-sampling',2(4X,F6.2))
27485       ENDIF
27486
27487       IF (MCGENE.EQ.1) THEN
27488          IF (ICSAMP.GT.0) THEN
27489          WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27490  1004    FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27491      &          ' event',3X,F9.1)
27492          IF (ISICHA.EQ.1) THEN
27493             WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27494  1005       FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27495      &             'of single chains  per event',13X,F9.1)
27496          ENDIF
27497          ENDIF
27498          IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
27499          WRITE(LOUT,1006)
27500  1006    FORMAT(/,1X,'chain system statistics:  (per event)',/,
27501      &       23X,'mean number of chains      mean number of chains',/,
27502      &       23X,'sampled    hadronized      having mass of a reso.')
27503          WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27504      &                     DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27505      &                     DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27506      &                  DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27507  1007    FORMAT(1X,'sea     - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27508      &          1X,'disea   - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27509      &          1X,'sea     - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27510      &          1X,'sea     - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27511      &          1X,'disea   - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27512      &          1X,'valence - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27513      &          1X,'valence - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27514      &          1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27515      &          1X,'fused chains      ',18X,F4.1,17X,F4.1,/)
27516          WRITE(LOUT,1008)
27517      &     (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27518      &     DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27519      &     DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27520      &     (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27521      &     (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27522      &     DBLE(IRHHA)/DBLE(ICREQU),
27523      &     DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27524      &     (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27525  1008    FORMAT(/,1X,'Rejection counter:  (NEVT = no. of events)',/,/,
27526      &       1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27527      &       F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27528      &       'Intrins. p_t (GETSPT)',21X,'IRPT     /NEVT = ',F7.2,/,
27529      &       1X,'Chain mass corr. for resonances (EVTRES)',2X,
27530      &       'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES)  IRRES(2) /',
27531      &       'NEVT = ',F7.2,/,43X,'LOMRES   /NEVT = ',F7.2,/,
27532      &       43X,'LOBRES   /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27533      &       ' 2-chain systems (CHKINE)  IRCHKI(1)/NEVT = ',F7.2,/,
27534      &       43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27535      &       'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27536      &       F7.2,/,1X,'Total no. of rej.',
27537      &       ' in chain-systems treatment (GETCSY)',/,43X,
27538      &       'IRHHA    /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27539      &       ' (not yet used!)',4X,'IRFRAG   /NEVT = ',F7.2,/,
27540      &       1X,'Total no. of rej. in DPM-treatment of one event',
27541      &       ' (EVENTA)',/,43X,'IREVT    /NEVT = ',F7.2,/,1X,
27542      &       'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27543      &       ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27544      &       'IREXCI(3) = ',I5,/)
27545          ENDIF
27546       ELSEIF (MCGENE.EQ.2) THEN
27547          WRITE(LOUT,1010) ELOJET
27548  1010    FORMAT(/,/,1X,'PHOJET-treatment of chain systems above  ',
27549      &          F4.1,' GeV')
27550          WRITE(LOUT,1011)
27551  1011    FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27552      &          30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27553      &          5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27554          WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27555      &                    (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27556      &                    (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27557      &                    ((ICEVTG(I,J),I=1,8),J=3,7),
27558      &                    ((ICEVTG(I,J),I=1,8),J=19,21),
27559      &                    (ICEVTG(I,8),I=1,8),
27560      &                    ((ICEVTG(I,J),I=1,8),J=22,24),
27561      &                    (ICEVTG(I,9),I=1,8),
27562      &                    ((ICEVTG(I,J),I=1,8),J=25,28),
27563      &                    ((ICEVTG(I,J),I=1,8),J=10,18)
27564  1012    FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27565      &          8I8,/,/,1X,'PHOJET ',8I8,/,'   sngl ',8I8,/,/,
27566      &          ' no-dif.',8I8,/,
27567      &          ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27568      &          ' diff-1 ',8I8,/,'  low   ',8I8,/,'  high  ',8I8,/,
27569      &          '  h-diff',8I8,/,' diff-2 ',8I8,/,'  low   ',8I8,/,
27570      &          '  high  ',8I8,/,'  h-diff',8I8,/,' dbl-di.',8I8,/,
27571      &          '  lo-lo ',8I8,/,'  hi-hi ',8I8,/,'  lo-hi ',8I8,/,
27572      &          '  hi-lo ',8I8,/,
27573      &          ' dir-ga.',8I8,/,/,' dir-1  ',8I8,/,' dir-2  ',8I8,/,
27574      &          ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27575      &          ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27576          WRITE(LOUT,1013)
27577  1013    FORMAT(/,1X,'2. chain system statistics -',
27578      &          ' mean numbers per evt:',/,30X,'---------------------',
27579      &          /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27580          IF (ICSAMP.GT.0) THEN
27581          WRITE(LOUT,1014)
27582      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27583      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27584      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27585  1014    FORMAT(/,1X,'req.to.    ',3E10.2,/,/,1X,'low rq.    ',3E10.2,/,
27586      &          1X,'low ac.    ',3E10.2,/,/,1X,'PHOJET     ',3E10.2,/,/,
27587      &          ' no-dif.    ',3E10.2,/,' el-sca.    ',3E10.2,/,
27588      &          ' qel-sc.    ',3E10.2,/,' dbl-Po.    ',3E10.2,/,
27589      &          ' diff-1     ',3E10.2,/,' diff-2     ',3E10.2,/,
27590      &          ' dbl-di.    ',3E10.2,/,' dir-ga.    ',3E10.2,/,/,
27591      &          ' dir-1      ',3E10.2,/,' dir-2      ',3E10.2,/,
27592      &          ' dbl-dir    ',3E10.2,/,' s-Pom.     ',3E10.2,/,
27593      &          ' h-Pom.     ',3E10.2,/,' s-Reg.     ',3E10.2,/,
27594      &          ' enh-trg    ',3E10.2,/,' enh-log    ',3E10.2)
27595          ENDIF
27596          WRITE(LOUT,1015)
27597  1015    FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27598          IF (ICSAMP.GT.0) THEN
27599          WRITE(LOUT,1016)
27600      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27601      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27602      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27603  1016    FORMAT(/,1X,'req.to.    ',5E10.2,/,/,1X,'low rq.    ',5E10.2,/,
27604      &          1X,'low ac.    ',5E10.2,/,/,1X,'PHOJET     ',5E10.2,/,/,
27605      &          ' no-dif.    ',5E10.2,/,' el-sca.    ',5E10.2,/,
27606      &          ' qel-sc.    ',5E10.2,/,' dbl-Po.    ',5E10.2,/,
27607      &          ' diff-1     ',5E10.2,/,' diff-2     ',5E10.2,/,
27608      &          ' dbl-di.    ',5E10.2,/,' dir-ga.    ',5E10.2,/,/,
27609      &          ' dir-1      ',5E10.2,/,' dir-2      ',5E10.2,/,
27610      &          ' dbl-dir    ',5E10.2,/,' s-Pom.     ',5E10.2,/,
27611      &          ' h-Pom.     ',5E10.2,/,' s-Reg.     ',5E10.2,/,
27612      &          ' enh-trg    ',5E10.2,/,' enh-log    ',5E10.2)
27613          ENDIF
27614
27615       ENDIF
27616       CALL DT_CHASTA(1)
27617
27618       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27619      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
27620          WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27621      &    DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27622      &    DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27623          WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27624      &    DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27625      &    DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27626          WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27627      &    DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27628      &    DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27629          WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27630      &    DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27631      &    DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27632          WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27633      &    DBRKA(3,1),DBRKA(3,2),
27634      &    DBRKA(3,3),DBRKA(3,4)
27635          WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27636      &    DBRKR(3,1),DBRKR(3,2),
27637      &    DBRKR(3,3),DBRKR(3,4)
27638          WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27639      &    DBRKA(3,5),DBRKA(3,6),
27640      &    DBRKA(3,7),DBRKA(3,8)
27641          WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27642      &    DBRKR(3,5),DBRKR(3,6),
27643      &    DBRKR(3,7),DBRKR(3,8)
27644       ENDIF
27645
27646       FAC = 1.0D0
27647       IF (MCGENE.EQ.2) THEN
27648
27649 C        CALL PHO_PHIST(-2,SIGMAX)
27650          CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27651
27652       ENDIF
27653
27654       CALL DT_XTIME
27655
27656       RETURN
27657       END
27658
27659 *$ CREATE DT_EVTOUT.FOR
27660 *COPY DT_EVTOUT
27661 *
27662 *===evtout=============================================================*
27663 *
27664       SUBROUTINE DT_EVTOUT(MODE)
27665
27666 ************************************************************************
27667 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27668 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27669 *                    4  plot entries of DTEVT1 and DTEVT2              *
27670 * This version dated 11.12.94 is written by S. Roesler                 *
27671 ************************************************************************
27672
27673       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27674       SAVE
27675
27676       PARAMETER ( LINP = 10 ,
27677      &            LOUT = 6 ,
27678      &            LDAT = 9 )
27679
27680 * event history
27681
27682       PARAMETER (NMXHKK=200000)
27683
27684       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27685      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27686      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27687
27688       DIMENSION IRANGE(NMXHKK)
27689
27690       IF (MODE.EQ.2) RETURN
27691
27692       CALL DT_EVTPLO(IRANGE,MODE)
27693
27694       RETURN
27695       END
27696
27697 *$ CREATE DT_EVTPLO.FOR
27698 *COPY DT_EVTPLO
27699 *
27700 *===evtplo=============================================================*
27701 *
27702       SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27703
27704 ************************************************************************
27705 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27706 *                    2  plot entries of DTEVT1 given by IRANGE         *
27707 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27708 *                    4  plot entries of DTEVT1 and DTEVT2              *
27709 *                    5  plot rejection counter                         *
27710 * This version dated 11.12.94 is written by S. Roesler                 *
27711 ************************************************************************
27712
27713       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27714       SAVE
27715
27716       PARAMETER ( LINP = 10 ,
27717      &            LOUT = 6 ,
27718      &            LDAT = 9 )
27719
27720       CHARACTER*16 CHAU
27721
27722 * event history
27723
27724       PARAMETER (NMXHKK=200000)
27725
27726       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27727      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27728      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27729
27730 * extended event history
27731       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27732      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27733      &                IHIST(2,NMXHKK)
27734
27735 * rejection counter
27736       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27737      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27738      &                IREXCI(3),IRDIFF(2),IRINC
27739
27740       DIMENSION IRANGE(NMXHKK)
27741
27742       IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
27743          WRITE(LOUT,1000)
27744  1000    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTEVT1/',/,
27745      &         15X,'           --------------------------',/,/,
27746      &             '       ST    ID  M1   M2   D1   D2     PX     PY',
27747      &             '     PZ      E       M',/)
27748          DO 1 I=1,NHKK
27749             WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27750      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27751      &                       PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27752      &                       PHKK(5,I)
27753 C           WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27754 C    &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27755 C    &                       PHKK(3,I),PHKK(4,I)
27756 C           WRITE(LOUT,'(4E15.4)')
27757 C    &         VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
27758  1001       FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
27759  1011       FORMAT(I5,I5,I6,4I5,2E15.5)
27760     1    CONTINUE
27761          WRITE(LOUT,*)
27762 C        DO 4 I=1,NHKK
27763 C           WRITE(LOUT,1006) I,ISTHKK(I),
27764 C    &                    VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
27765 C    &                    WHKK(2,I),WHKK(3,I)
27766 C1006       FORMAT(1X,I4,I6,6E10.3)
27767 C   4    CONTINUE
27768       ENDIF
27769
27770       IF (MODE.EQ.2) THEN
27771          WRITE(LOUT,1000)
27772          NC = 0
27773     2    CONTINUE
27774          NC = NC+1
27775          IF (IRANGE(NC).EQ.-100) GOTO 9999
27776          I = IRANGE(NC)
27777          WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27778      &                    JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27779      &                    PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27780      &                    PHKK(5,I)
27781          GOTO 2
27782       ENDIF
27783
27784       IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
27785          WRITE(LOUT,1002)
27786  1002    FORMAT(/,1X,'EVTPLO:',14X,
27787      &         ' content of COMMON /DTEVT1/,/DTEVT2/',/,
27788      &         15X,'        -----------------------------------',/,/,
27789      &             '       ST    ID   M1   M2   D1   D2  IDR  IDXR',
27790      &             ' NOBAM IDCH    M',/)
27791          DO 3 I=1,NHKK
27792 C           IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
27793                KF    = IDHKK(I)
27794                IDCHK = KF/10000
27795                IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
27796      &            (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
27797
27798                CALL PYNAME(KF,CHAU)
27799
27800                WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27801      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27802      &                       IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
27803      &                       PHKK(5,I),CHAU
27804  1003          FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
27805 C           ENDIF
27806     3    CONTINUE
27807       ENDIF
27808
27809       IF (MODE.EQ.5) THEN
27810          WRITE(LOUT,1004)
27811  1004    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTREJC/',/,
27812      &         15X,'           --------------------------',/)
27813          WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
27814      &                    IRSEA,IRCRON
27815  1005    FORMAT(1X,'IRPT   = ',I5,'  IRHHA = ',I5,/,
27816      &          1X,'IRRES  = ',2I5,'  LOMRES = ',I5,'  LOBRES = ',I5,/,
27817      &          1X,'IREMC  = ',10I5,/,
27818      &          1X,'IRFRAG = ',I5,'  IRSEA = ',I5,' IRCRON = ',I5,/)
27819       ENDIF
27820
27821  9999 RETURN
27822       END
27823
27824 *$ CREATE DT_EVTPUT.FOR
27825 *COPY DT_EVTPUT
27826 *
27827 *===evtput=============================================================*
27828 *
27829       SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
27830
27831       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27832       SAVE
27833
27834       PARAMETER ( LINP = 10 ,
27835      &            LOUT = 6 ,
27836      &            LDAT = 9 )
27837
27838       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
27839      &           TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
27840
27841 * event history
27842
27843       PARAMETER (NMXHKK=200000)
27844
27845       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27846      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27847      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27848
27849 * extended event history
27850       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27851      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27852      &                IHIST(2,NMXHKK)
27853
27854 * Lorentz-parameters of the current interaction
27855       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27856      &                UMO,PPCM,EPROJ,PPROJ
27857
27858 * particle properties (BAMJET index convention)
27859       CHARACTER*8  ANAME
27860       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27861      &                IICH(210),IIBAR(210),K1(210),K2(210)
27862
27863 C     IF (MODE.GT.100) THEN
27864 C        WRITE(LOUT,'(1X,A,I5,A,I5)')
27865 C    &        'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
27866 C        NHKK = NHKK-MODE+100
27867 C        RETURN
27868 C     ENDIF
27869       MO1  = M1
27870       MO2  = M2
27871       NHKK = NHKK+1
27872
27873       IF (NHKK.GT.NMXHKK) THEN
27874          WRITE(LOUT,1000) NHKK
27875  1000    FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
27876      &             '! program execution stopped..')
27877          STOP
27878       ENDIF
27879       IF (M1.LT.0) MO1 = NHKK+M1
27880       IF (M2.LT.0) MO2 = NHKK+M2
27881       ISTHKK(NHKK)   = IST
27882       IDHKK(NHKK)    = ID
27883       JMOHKK(1,NHKK) = MO1
27884       JMOHKK(2,NHKK) = MO2
27885       JDAHKK(1,NHKK) = 0
27886       JDAHKK(2,NHKK) = 0
27887       IDRES(NHKK)    = IDR
27888       IDXRES(NHKK)   = IDXR
27889       IDCH(NHKK)     = IDC
27890 ** here we need to do something..
27891       IF (ID.EQ.88888) THEN
27892          IDMO1 = ABS(IDHKK(MO1))
27893          IDMO2 = ABS(IDHKK(MO2))
27894          IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
27895          IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
27896          IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
27897          IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
27898       ELSE
27899          NOBAM(NHKK) = 0
27900       ENDIF
27901       IDBAM(NHKK) = IDT_ICIHAD(ID)
27902       IF (MO1.GT.0) THEN
27903          IF (JDAHKK(1,MO1).NE.0) THEN
27904             JDAHKK(2,MO1) = NHKK
27905          ELSE
27906             JDAHKK(1,MO1) = NHKK
27907          ENDIF
27908       ENDIF
27909       IF (MO2.GT.0) THEN
27910          IF (JDAHKK(1,MO2).NE.0) THEN
27911             JDAHKK(2,MO2) = NHKK
27912          ELSE
27913             JDAHKK(1,MO2) = NHKK
27914          ENDIF
27915       ENDIF
27916 C      IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
27917 C         PTOT   = SQRT(PX**2+PY**2+PZ**2)
27918 C         AM0    = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
27919 C         AMRQ   = AAM(IDBAM(NHKK))
27920 C         AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
27921 C         IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
27922 C     &       (PTOT.GT.ZERO)) THEN
27923 C            DELTA = -AMDIF2/(2.0D0*(E+PTOT))
27924 CC           DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
27925 C            E     = E+DELTA
27926 C            PTOT1 = PTOT-DELTA
27927 C            PX    = PX*PTOT1/PTOT
27928 C            PY    = PY*PTOT1/PTOT
27929 C            PZ    = PZ*PTOT1/PTOT
27930 C         ENDIF
27931 C      ENDIF
27932       PHKK(1,NHKK) = PX
27933       PHKK(2,NHKK) = PY
27934       PHKK(3,NHKK) = PZ
27935       PHKK(4,NHKK) = E
27936       PTOT = SQRT( PX**2+PY**2+PZ**2 )
27937       IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
27938          PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
27939          PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
27940       ELSE
27941          PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
27942 C        IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
27943 C    &      WRITE(LOUT,'(1X,A,G10.3)')
27944 C    &        'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
27945          PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
27946       ENDIF
27947       IDCHK = ID/10000
27948       IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
27949 * special treatment for chains:
27950 *    z coordinate of chain in Lab  = pos. of target nucleon
27951 *    time of chain-creation in Lab = time of passage of projectile
27952 *                                    nucleus at pos. of taget nucleus
27953 C        VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
27954 C        VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
27955          VHKK(1,NHKK) = VHKK(1,MO2)
27956          VHKK(2,NHKK) = VHKK(2,MO2)
27957          VHKK(3,NHKK) = VHKK(3,MO2)
27958          VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
27959 C        WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
27960 C        WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
27961          WHKK(1,NHKK) = WHKK(1,MO1)
27962          WHKK(2,NHKK) = WHKK(2,MO1)
27963          WHKK(3,NHKK) = WHKK(3,MO1)
27964          WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
27965       ELSE
27966          IF (MO1.GT.0) THEN
27967             DO 1 I=1,4
27968                VHKK(I,NHKK) = VHKK(I,MO1)
27969                WHKK(I,NHKK) = WHKK(I,MO1)
27970     1       CONTINUE
27971          ELSE
27972             DO 2 I=1,4
27973                VHKK(I,NHKK) = ZERO
27974                WHKK(I,NHKK) = ZERO
27975     2       CONTINUE
27976          ENDIF
27977       ENDIF
27978
27979       RETURN
27980       END
27981
27982 *$ CREATE DT_CHASTA.FOR
27983 *COPY DT_CHASTA
27984 *
27985 *===chasta=============================================================*
27986 *
27987       SUBROUTINE DT_CHASTA(MODE)
27988
27989 ************************************************************************
27990 * This subroutine performs CHAin STAtistics and checks sequence of     *
27991 * partons in dtevt1 and sorts them with projectile partons coming      *
27992 * first if necessary.                                                  *
27993 *                                                                      *
27994 * This version dated  8.5.00  is written by S. Roesler.                *
27995 ************************************************************************
27996
27997       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27998       SAVE
27999
28000       PARAMETER ( LINP = 10 ,
28001      &            LOUT = 6 ,
28002      &            LDAT = 9 )
28003
28004       CHARACTER*5 CCHTYP
28005
28006 * event history
28007
28008       PARAMETER (NMXHKK=200000)
28009
28010       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28011      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28012      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28013
28014 * extended event history
28015       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28016      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28017      &                IHIST(2,NMXHKK)
28018
28019 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28020       PARAMETER (MAXCHN=10000)
28021       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28022
28023       DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28024      &          CCHTYP(9),ICHSTA(10),ITOT(10)
28025       DATA ICHCFG /1800*0/
28026       DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28027       DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28028       DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28029       DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28030       DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28031       DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28032       DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28033      &              'ad aq',' d ad','ad d ',' g g '/
28034 *
28035 * initialization
28036 *
28037       IF (MODE.EQ.-1) THEN
28038          NCHAIN = 0
28039 *
28040 * loop over DTEVT1 and analyse chain configurations
28041 *
28042       ELSEIF (MODE.EQ.0) THEN
28043          DO 21 IDX=NPOINT(3),NHKK
28044             IDCHK = IDHKK(IDX)/10000
28045             IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28046      &          (IDHKK(IDX).NE.80000).AND.
28047      &          (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28048                IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28049                   WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28050      &                          ' at entry ',IDX
28051                   GOTO 21
28052                ENDIF
28053 *
28054                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28055                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28056                IMO1 = IST1/10
28057                IMO1 = IST1-10*IMO1
28058                IMO2 = IST2/10
28059                IMO2 = IST2-10*IMO2
28060 *   swop parton entries if necessary since we need projectile partons
28061 *   to come first in the common
28062                IF (IMO1.GT.IMO2) THEN
28063                   NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28064                   DO 22 K=1,NPTN/2
28065                      I0 = JMOHKK(1,IDX)-1+K
28066                      I1 = JMOHKK(2,IDX)+1-K
28067                      ITMP = ISTHKK(I0)
28068                      ISTHKK(I0) = ISTHKK(I1)
28069                      ISTHKK(I1) = ITMP
28070                      ITMP = IDHKK(I0)
28071                      IDHKK(I0) = IDHKK(I1)
28072                      IDHKK(I1) = ITMP
28073                      IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28074      &                  JDAHKK(1,JMOHKK(1,I0)) = I1
28075                      IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28076      &                  JDAHKK(2,JMOHKK(1,I0)) = I1
28077                      IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28078      &                  JDAHKK(1,JMOHKK(2,I0)) = I1
28079                      IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28080      &                  JDAHKK(2,JMOHKK(2,I0)) = I1
28081                      IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28082      &                  JDAHKK(1,JMOHKK(1,I1)) = I0
28083                      IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28084      &                  JDAHKK(2,JMOHKK(1,I1)) = I0
28085                      IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28086      &                  JDAHKK(1,JMOHKK(2,I1)) = I0
28087                      IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28088      &                  JDAHKK(2,JMOHKK(2,I1)) = I0
28089                      ITMP = JMOHKK(1,I0)
28090                      JMOHKK(1,I0) = JMOHKK(1,I1)
28091                      JMOHKK(1,I1) = ITMP
28092                      ITMP = JMOHKK(2,I0)
28093                      JMOHKK(2,I0) = JMOHKK(2,I1)
28094                      JMOHKK(2,I1) = ITMP
28095                      ITMP = JDAHKK(1,I0)
28096                      JDAHKK(1,I0) = JDAHKK(1,I1)
28097                      JDAHKK(1,I1) = ITMP
28098                      ITMP = JDAHKK(2,I0)
28099                      JDAHKK(2,I0) = JDAHKK(2,I1)
28100                      JDAHKK(2,I1) = ITMP
28101                      DO 23 J=1,4
28102                         RTMP1 = PHKK(J,I0)
28103                         RTMP2 = VHKK(J,I0)
28104                         RTMP3 = WHKK(J,I0)
28105                         PHKK(J,I0) = PHKK(J,I1)
28106                         VHKK(J,I0) = VHKK(J,I1)
28107                         WHKK(J,I0) = WHKK(J,I1)
28108                         PHKK(J,I1) = RTMP1
28109                         VHKK(J,I1) = RTMP2
28110                         WHKK(J,I1) = RTMP3
28111    23                CONTINUE
28112                      RTMP1 = PHKK(5,I0)
28113                      PHKK(5,I0) = PHKK(5,I1)
28114                      PHKK(5,I1) = RTMP1
28115                      ITMP = IDRES(I0)
28116                      IDRES(I0) = IDRES(I1)
28117                      IDRES(I1) = ITMP
28118                      ITMP = IDXRES(I0)
28119                      IDXRES(I0) = IDXRES(I1)
28120                      IDXRES(I1) = ITMP
28121                      ITMP = NOBAM(I0)
28122                      NOBAM(I0) = NOBAM(I1)
28123                      NOBAM(I1) = ITMP
28124                      ITMP = IDBAM(I0)
28125                      IDBAM(I0) = IDBAM(I1)
28126                      IDBAM(I1) = ITMP
28127                      ITMP = IDCH(I0)
28128                      IDCH(I0) = IDCH(I1)
28129                      IDCH(I1) = ITMP
28130                      ITMP = IHIST(1,I0)
28131                      IHIST(1,I0) = IHIST(1,I1)
28132                      IHIST(1,I1) = ITMP
28133                      ITMP = IHIST(2,I0)
28134                      IHIST(2,I0) = IHIST(2,I1)
28135                      IHIST(2,I1) = ITMP
28136    22             CONTINUE
28137                ENDIF
28138                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28139                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28140 *
28141 *   parton 1 (projectile side)
28142                IF (IST1.EQ.21) THEN
28143                   IDX1 = 1
28144                ELSEIF (IST1.EQ.22) THEN
28145                   IDX1 = 2
28146                ELSEIF (IST1.EQ.31) THEN
28147                   IDX1 = 3
28148                ELSEIF (IST1.EQ.32) THEN
28149                   IDX1 = 4
28150                ELSEIF (IST1.EQ.41) THEN
28151                   IDX1 = 5
28152                ELSEIF (IST1.EQ.42) THEN
28153                   IDX1 = 6
28154                ELSEIF (IST1.EQ.51) THEN
28155                   IDX1 = 7
28156                ELSEIF (IST1.EQ.52) THEN
28157                   IDX1 = 8
28158                ELSEIF (IST1.EQ.61) THEN
28159                   IDX1 = 9
28160                ELSEIF (IST1.EQ.62) THEN
28161                   IDX1 = 10
28162                ELSE
28163 c                 WRITE(LOUT,*)
28164 c    &               ' CHASTA: unknown parton status flag (',
28165 c    &               IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28166                   GOTO 21
28167                ENDIF
28168                ID = IDHKK(JMOHKK(1,IDX))
28169                IF (ABS(ID).LE.4) THEN
28170                   IF (ID.GT.0) THEN
28171                      ITYP1 = 1
28172                   ELSE
28173                      ITYP1 = 2
28174                   ENDIF
28175                ELSEIF (ABS(ID).GE.1000) THEN
28176                   IF (ID.GT.0) THEN
28177                      ITYP1 = 3
28178                   ELSE
28179                      ITYP1 = 4
28180                   ENDIF
28181                ELSEIF (ID.EQ.21) THEN
28182                   ITYP1 = 5
28183                ELSE
28184                   WRITE(LOUT,*)
28185      &               ' CHASTA: inconsistent parton identity (',
28186      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28187                   GOTO 21
28188                ENDIF
28189 *
28190 *   parton 2 (target side)
28191                IF (IST2.EQ.21) THEN
28192                   IDX2 = 1
28193                ELSEIF (IST2.EQ.22) THEN
28194                   IDX2 = 2
28195                ELSEIF (IST2.EQ.31) THEN
28196                   IDX2 = 3
28197                ELSEIF (IST2.EQ.32) THEN
28198                   IDX2 = 4
28199                ELSEIF (IST2.EQ.41) THEN
28200                   IDX2 = 5
28201                ELSEIF (IST2.EQ.42) THEN
28202                   IDX2 = 6
28203                ELSEIF (IST2.EQ.51) THEN
28204                   IDX2 = 7
28205                ELSEIF (IST2.EQ.52) THEN
28206                   IDX2 = 8
28207                ELSEIF (IST2.EQ.61) THEN
28208                   IDX2 = 9
28209                ELSEIF (IST2.EQ.62) THEN
28210                   IDX2 = 10
28211                ELSE
28212 c                 WRITE(LOUT,*)
28213 c    &               ' CHASTA: unknown parton status flag (',
28214 c    &               IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28215                   GOTO 21
28216                ENDIF
28217                ID = IDHKK(JMOHKK(2,IDX))
28218                IF (ABS(ID).LE.4) THEN
28219                   IF (ID.GT.0) THEN
28220                      ITYP2 = 1
28221                   ELSE
28222                      ITYP2 = 2
28223                   ENDIF
28224                ELSEIF (ABS(ID).GE.1000) THEN
28225                   IF (ID.GT.0) THEN
28226                      ITYP2 = 3
28227                   ELSE
28228                      ITYP2 = 4
28229                   ENDIF
28230                ELSEIF (ID.EQ.21) THEN
28231                   ITYP2 = 5
28232                ELSE
28233                   WRITE(LOUT,*)
28234      &               ' CHASTA: inconsistent parton identity (',
28235      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28236                   GOTO 21
28237                ENDIF
28238 *
28239 *   fill counter
28240                ITYPE = ICHTYP(ITYP1,ITYP2)
28241                IF (ITYPE.NE.0) THEN
28242                   ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28243                   NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28244                   ICHCFG(IDX1,IDX2,ITYPE,2) =
28245      &               ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28246
28247                   NCHAIN = NCHAIN+1
28248                   IF (NCHAIN.GT.MAXCHN) THEN
28249                      WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28250      &                  NCHAIN,MAXCHN
28251                      STOP
28252                   ENDIF
28253                   IDXCHN(1,NCHAIN) = IDX
28254                   IDXCHN(2,NCHAIN) = ITYPE
28255                ELSE
28256                   WRITE(LOUT,*)
28257      &               ' CHASTA: inconsistent chain at entry ',IDX
28258                   GOTO 21
28259                ENDIF
28260             ENDIF
28261    21    CONTINUE
28262 *
28263 * write statistics to output unit
28264 *
28265       ELSEIF (MODE.EQ.1) THEN
28266          WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28267          DO 31 I=1,10
28268             WRITE(LOUT,'(/,2A)')
28269      &         ' -----------------------------------------',
28270      &         '------------------------------------'
28271             WRITE(LOUT,'(2A)')
28272      &         ' p\\t         21     22     31     32     41',
28273      &         '     42     51     52     61     62'
28274             WRITE(LOUT,'(2A)')
28275      &         ' -----------------------------------------',
28276      &         '------------------------------------'
28277             DO 32 J=1,10
28278                ITOT(J) = 0
28279                DO 33 K=1,9
28280                   ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28281    33          CONTINUE
28282    32       CONTINUE
28283             WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28284             DO 34 K=1,9
28285                ISUM = 0
28286                DO 35 J=1,10
28287                   ISUM = ISUM+ICHCFG(I,J,K,1)
28288    35          CONTINUE
28289                IF (ISUM.GT.0)
28290      &            WRITE(LOUT,'(1X,A5,2X,10I7)')
28291      &               CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28292    34       CONTINUE
28293 C           WRITE(LOUT,'(2A)')
28294 C    &         ' -----------------------------------------',
28295 C    &         '-------------------------------'
28296    31    CONTINUE
28297 *
28298       ELSE
28299          WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28300          STOP
28301       ENDIF
28302
28303       RETURN
28304       END
28305 *$ CREATE PHO_PHIST.FOR
28306 *COPY PHO_PHIST
28307 *
28308 *===pohist=============================================================*
28309 *
28310       SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28311
28312       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28313       SAVE
28314
28315       PARAMETER ( LINP = 10 ,
28316      &            LOUT = 6 ,
28317      &            LDAT = 9 )
28318
28319       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28320
28321 * Glauber formalism: cross sections
28322       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28323      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28324      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28325      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28326      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28327      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28328      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28329      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28330      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28331      &                BSLOPE,NEBINI,NQBINI
28332
28333       ILAB = 0
28334       IF (IMODE.EQ.10) THEN
28335          IMODE = 1
28336          ILAB  = 1
28337       ENDIF
28338       IF (ABS(IMODE).LT.1000) THEN
28339 * PHOJET-statistics
28340 C        CALL POHISX(IMODE,WEIGHT)
28341          IF (IMODE.EQ.-1) THEN
28342             MODE = 1
28343             XSTOT(1,1,1) = WEIGHT
28344          ENDIF
28345          IF (IMODE.EQ. 1) MODE = 2
28346          IF (IMODE.EQ.-2) MODE = 3
28347          IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28348 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28349 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28350          CALL DT_HISTOG(MODE)
28351          CALL DT_USRHIS(MODE)
28352       ELSE
28353 * DTUNUC-statistics
28354          MODE = IMODE/1000
28355 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28356 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28357          CALL DT_HISTOG(MODE)
28358          CALL DT_USRHIS(MODE)
28359       ENDIF
28360
28361       RETURN
28362       END
28363
28364 *$ CREATE DT_SWPPHO.FOR
28365 *COPY DT_SWPPHO
28366 *
28367 *===swppho=============================================================*
28368 *
28369       SUBROUTINE DT_SWPPHO(ILAB)
28370
28371       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28372       SAVE
28373
28374       PARAMETER ( LINP = 10 ,
28375      &            LOUT = 6 ,
28376      &            LDAT = 9 )
28377
28378       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28379
28380       LOGICAL LSTART
28381
28382 * event history
28383
28384       PARAMETER (NMXHKK=200000)
28385
28386       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28387      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28388      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28389
28390 * extended event history
28391       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28392      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28393      &                IHIST(2,NMXHKK)
28394
28395 * flags for input different options
28396       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28397       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28398      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28399
28400 * properties of photon/lepton projectiles
28401       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28402
28403 **PHOJET105a
28404 C     PARAMETER (NMXHEP=2000)
28405 C     COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28406 C    &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28407 C     COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28408 C     COMMON /PLASAV/ PLAB
28409 **PHOJET110
28410 C  standard particle data interface
28411       INTEGER NMXHEP
28412
28413       PARAMETER (NMXHEP=4000)
28414
28415       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28416       DOUBLE PRECISION PHEP,VHEP
28417       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28418      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28419      &                VHEP(4,NMXHEP)
28420 C  extension to standard particle data interface (PHOJET specific)
28421       INTEGER IMPART,IPHIST,ICOLOR
28422       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28423
28424 C  global event kinematics and particle IDs
28425       INTEGER IFPAP,IFPAB
28426       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28427       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28428 **
28429       DATA ICOUNT/0/
28430
28431       DATA LSTART /.TRUE./
28432
28433 C     IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28434       IF ((IFRAME.EQ.1).AND.LSTART) THEN
28435          UMO  = ECM
28436          ELA  = ZERO
28437          PLA  = ZERO
28438          IDP  = IDT_ICIHAD(IFPAP(1))
28439          IDT  = IDT_ICIHAD(IFPAP(2))
28440          VIRT = PVIRT(1)
28441          CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28442          PLAB = PLA
28443          LSTART = .FALSE.
28444       ENDIF
28445
28446       NHKK   = 0
28447       ICOUNT = ICOUNT+1
28448 C     NEVHKK = NEVHEP
28449       NEVHKK = ICOUNT
28450       IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28451       DO 1 I=3,NHEP
28452          IF (ISTHEP(I).EQ.1) THEN
28453             NHKK = NHKK+1
28454             ISTHKK(NHKK) = 1
28455             IDHKK(NHKK)  = IDHEP(I)
28456             JMOHKK(1,NHKK) = 0
28457             JMOHKK(2,NHKK) = 0
28458             JDAHKK(1,NHKK) = 0
28459             JDAHKK(2,NHKK) = 0
28460             DO 2 K=1,4
28461                PHKK(K,NHKK) = PHEP(K,I)
28462                VHKK(K,NHKK) = ZERO
28463                WHKK(K,NHKK) = ZERO
28464     2       CONTINUE
28465             IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28466      &         CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28467      &                    PHKK(3,NHKK),PHKK(4,NHKK),-3)
28468             PHKK(5,NHKK) = PHEP(5,I)
28469             IDRES(NHKK)  = 0
28470             IDXRES(NHKK) = 0
28471             NOBAM(NHKK)  = 0
28472             IDBAM(NHKK)  = IDT_ICIHAD(IDHEP(I))
28473             IDCH(NHKK)   = 0
28474          ENDIF
28475     1 CONTINUE
28476
28477       RETURN
28478       END
28479
28480 *$ CREATE DT_HISTOG.FOR
28481 *COPY DT_HISTOG
28482 *
28483 *===histog=============================================================*
28484 *
28485       SUBROUTINE DT_HISTOG(MODE)
28486
28487 ************************************************************************
28488 * This version dated 25.03.96 is written by S. Roesler                 *
28489 ************************************************************************
28490
28491       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28492       SAVE
28493
28494       PARAMETER ( LINP = 10 ,
28495      &            LOUT = 6 ,
28496      &            LDAT = 9 )
28497
28498       LOGICAL LFSP,LRNL
28499
28500 * event history
28501
28502       PARAMETER (NMXHKK=200000)
28503
28504       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28505      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28506      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28507
28508 * extended event history
28509       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28510      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28511      &                IHIST(2,NMXHKK)
28512
28513 * event flag used for histograms
28514       COMMON /DTNORM/ ICEVT,IEVHKK
28515
28516 * flags for activated histograms
28517       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28518
28519       IEVHKK = NEVHKK
28520       GOTO (1,2,3) MODE
28521
28522 *------------------------------------------------------------------
28523 * initialization
28524     1 CONTINUE
28525       ICEVT = 0
28526       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28527       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28528
28529       RETURN
28530 *------------------------------------------------------------------
28531 * filling of histogram with event-record
28532     2 CONTINUE
28533       ICEVT = ICEVT+1
28534
28535       DO 20 I=1,NHKK
28536          CALL DT_SWPFSP(I,LFSP,LRNL)
28537          IF (LFSP) THEN
28538             IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28539             IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28540          ENDIF
28541          IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28542    20 CONTINUE
28543       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28544
28545       RETURN
28546 *------------------------------------------------------------------
28547 * output
28548     3 CONTINUE
28549       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28550       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28551
28552       RETURN
28553       END
28554
28555 *$ CREATE DT_SWPFSP.FOR
28556 *COPY DT_SWPFSP
28557 *
28558 *===swpfsp=============================================================*
28559 *
28560       SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28561
28562       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28563       SAVE
28564       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28565       PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28566      &           PI   =TWOPI/TWO,
28567      &           BOG  =TWOPI/360.0D0)
28568
28569 * event history
28570
28571       PARAMETER (NMXHKK=200000)
28572
28573       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28574      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28575      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28576
28577 * extended event history
28578       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28579      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28580      &                IHIST(2,NMXHKK)
28581
28582 * particle properties (BAMJET index convention)
28583       CHARACTER*8  ANAME
28584       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28585      &                IICH(210),IIBAR(210),K1(210),K2(210)
28586
28587 * Lorentz-parameters of the current interaction
28588       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28589      &                UMO,PPCM,EPROJ,PPROJ
28590
28591 * flags for input different options
28592       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28593       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28594      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28595
28596 *      INCLUDE '(DIMPAR)'
28597 *     Taken from FLUKA
28598       PARAMETER ( MXXRGN =20000 )
28599       PARAMETER ( MXXMDF =  710 )
28600       PARAMETER ( MXXMDE =  702 )
28601       PARAMETER ( MFSTCK =40000 )
28602       PARAMETER ( MESTCK =  100 )
28603       PARAMETER ( MOSTCK = 2000 )
28604       PARAMETER ( MXPRSN =  100 )
28605       PARAMETER ( MXPDPM =  800 )
28606       PARAMETER ( MXPSCS =30000 )
28607       PARAMETER ( MXGLWN =  300 )
28608       PARAMETER ( MXOUTU =   50 )
28609       PARAMETER ( NALLWP =   64 )
28610       PARAMETER ( NELEMX =   80 )
28611       PARAMETER ( MPDPDX =   18 )
28612       PARAMETER ( MXHTTR =  260 )
28613       PARAMETER ( MXSEAX =   20 )
28614       PARAMETER ( MXHTNC = MXSEAX + 1 )
28615       PARAMETER ( ICOMAX = 2400 )
28616       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
28617       PARAMETER ( NSTBIS =  304 )
28618       PARAMETER ( NQSTIS =   46 )
28619       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
28620       PARAMETER ( MXPABL =  120 )
28621       PARAMETER ( IDMAXP =  450 )
28622       PARAMETER ( IDMXDC = 2000 )
28623       PARAMETER ( MXMCIN =  410 )
28624       PARAMETER ( IHYPMX =    4 )
28625       PARAMETER ( MKBMX1 =   11 )
28626       PARAMETER ( MKBMX2 =   11 )
28627       PARAMETER ( MXIRRD = 2500 )
28628       PARAMETER ( MXTRDC = 1500 )
28629       PARAMETER ( NKTL   =   17 )
28630       PARAMETER ( NBLNMX = 40000000 )
28631
28632 *      INCLUDE '(PAREVT)'
28633 *     Taken from FLUKA
28634       PARAMETER ( FRDIFF = 0.2D+00 )
28635       PARAMETER ( ETHSEA = 1.0D+00 )
28636 *
28637       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28638      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
28639      &        LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
28640      &        LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
28641       COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
28642      &                  LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28643      &                  LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28644      &                  LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
28645      &                  LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
28646      &                  LVP2XX, LV2XNW, LNWV2X, LEVFIN
28647
28648 * temporary storage for one final state particle
28649       LOGICAL LFRAG,LGREY,LBLACK
28650       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28651      &                SINTHE,COSTHE,THETA,THECMS,
28652      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28653      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28654      &                LFRAG,LGREY,LBLACK
28655
28656       LOGICAL LFSP,LRNL
28657
28658       LFSP = .FALSE.
28659       LRNL = .FALSE.
28660       ISTRNL = 1000
28661       MULDEF = 1
28662       IF (LEVPRT) ISTRNL = 1001
28663
28664       IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28665          IST    = ISTHKK(IDX)
28666          IDPDG  = IDHKK(IDX)
28667          LFRAG  = .FALSE.
28668          IF (IDHKK(IDX).LT.80000) THEN
28669             IDBJT  = IDBAM(IDX)
28670             IBARY  = IIBAR(IDBJT)
28671             ICHAR  = IICH(IDBJT)
28672             AMASS  = AAM(IDBJT)
28673          ELSEIF (IDHKK(IDX).EQ.80000) THEN
28674             IDBJT  = 0
28675             IBARY  = IDRES(IDX)
28676             ICHAR  = IDXRES(IDX)
28677             AMASS  = PHKK(5,IDX)
28678             INUT   = IBARY-ICHAR
28679             IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28680             IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28681             IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28682             IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28683             IF (IDBJT.EQ.0) LFRAG = .TRUE.
28684          ELSE
28685             GOTO 9999
28686          ENDIF
28687          PE     = PHKK(4,IDX)
28688          PX     = PHKK(1,IDX)
28689          PY     = PHKK(2,IDX)
28690          PZ     = PHKK(3,IDX)
28691          PT2    = PX**2+PY**2
28692          PT     = SQRT(PT2)
28693          PTOT   = SQRT(PT2+PZ**2)
28694          SINTHE = PT/MAX(PTOT,TINY14)
28695          COSTHE = PZ/MAX(PTOT,TINY14)
28696          IF (COSTHE.GT.ONE) THEN
28697             THETA = ZERO
28698          ELSEIF (COSTHE.LT.-ONE) THEN
28699             THETA = TWOPI/2.0D0
28700          ELSE
28701             THETA = ACOS(COSTHE)
28702          ENDIF
28703          EKIN   = PE-AMASS
28704 **sr 15.4.96 new E_t-definition
28705          IF (IBARY.GT.0) THEN
28706             ET = EKIN*SINTHE
28707          ELSEIF (IBARY.LT.0) THEN
28708             ET = (EKIN+TWO*AMASS)*SINTHE
28709          ELSE
28710             ET = PE*SINTHE
28711          ENDIF
28712 **
28713          XLAB   = PZ/MAX(PPROJ,TINY14)
28714 C        XLAB   = PE/MAX(EPROJ,TINY14)
28715          BETA   = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28716      &                     *(ONE+AMASS/MAX(PE,TINY14)) ))
28717          PPLUS  = PE+PZ
28718          PMINUS = PE-PZ
28719          IF (PMINUS.GT.TINY14) THEN
28720             YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28721          ELSE
28722             YY = 100.0D0
28723          ENDIF
28724          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28725             ETA = -LOG(TAN(THETA/TWO))
28726          ELSE
28727             ETA = 100.0D0
28728          ENDIF
28729          IF (IFRAME.EQ.1) THEN
28730             CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28731             PPLUS  = EECMS+PZCMS
28732             PMINUS = EECMS-PZCMS
28733             IF ((PPLUS*PMINUS).GT.TINY14) THEN
28734                YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28735             ELSE
28736                YYCMS = 100.0D0
28737             ENDIF
28738             PTOTCM = SQRT(PT2+PZCMS**2)
28739             COSTH = PZCMS/MAX(PTOTCM,TINY14)
28740             IF (COSTH.GT.ONE) THEN
28741                THECMS = ZERO
28742             ELSEIF (COSTH.LT.-ONE) THEN
28743                THECMS = TWOPI/2.0D0
28744             ELSE
28745                THECMS = ACOS(COSTH)
28746             ENDIF
28747             IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28748                ETACMS = -LOG(TAN(THECMS/TWO))
28749             ELSE
28750                ETACMS = 100.0D0
28751             ENDIF
28752             XF = PZCMS/MAX(PPCM,TINY14)
28753             THECMS = THECMS/BOG
28754          ELSE
28755             PZCMS  = PZ
28756             EECMS  = PE
28757             YYCMS  = YY
28758             ETACMS = ETA
28759             XF     = XLAB
28760             THECMS = THETA/BOG
28761          ENDIF
28762          THETA  = THETA/BOG
28763
28764 * set flag for "grey/black"
28765          LGREY  = .FALSE.
28766          LBLACK = .FALSE.
28767          EK     = EKIN
28768          IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28769          IF (MULDEF.EQ.1) THEN
28770 *  EMU01-Def.
28771             IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28772      &                              (EK.LE.375.0D-3)      ).OR.
28773      &           ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28774      &                              (EK.LE. 56.0D-3)      ).OR.
28775      &           ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28776      &                              (EK.LE. 56.0D-3)      ).OR.
28777      &           ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28778      &                              (EK.LE.198.0D-3)      ).OR.
28779      &           ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28780      &                              (EK.LE.198.0D-3)      ).OR.
28781      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28782      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28783      &             (IDBJT.NE.16).AND.
28784      &             (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)    ) )
28785      &         LGREY = .TRUE.
28786             IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28787      &           ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28788      &           ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28789      &           ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28790      &           ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28791      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28792      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28793      &             (IDBJT.NE.16).AND.(BETA.LE.0.23D0)  ) )
28794      &         LBLACK = .TRUE.
28795          ELSE
28796 *  common Def.
28797             IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28798             IF (BETA.LE.0.23D0) LBLACK=.TRUE.
28799          ENDIF
28800          LFSP = .TRUE.
28801       ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
28802          IST    = ISTHKK(IDX)
28803          IDPDG  = IDHKK(IDX)
28804          LFRAG  = .TRUE.
28805          IDBJT  = 0
28806          IBARY  = IDRES(IDX)
28807          ICHAR  = IDXRES(IDX)
28808          AMASS  = PHKK(5,IDX)
28809          PE     = PHKK(4,IDX)
28810          PX     = PHKK(1,IDX)
28811          PY     = PHKK(2,IDX)
28812          PZ     = PHKK(3,IDX)
28813          PT2    = PX**2+PY**2
28814          PT     = SQRT(PT2)
28815          PTOT   = SQRT(PT2+PZ**2)
28816          SINTHE = PT/MAX(PTOT,TINY14)
28817          COSTHE = PZ/MAX(PTOT,TINY14)
28818          IF (COSTHE.GT.ONE) THEN
28819             THETA = ZERO
28820          ELSEIF (COSTHE.LT.-ONE) THEN
28821             THETA = TWOPI/2.0D0
28822          ELSE
28823             THETA  = ACOS(COSTHE)
28824          ENDIF
28825          EKIN   = PE-AMASS
28826 **sr 15.4.96 new E_t-definition
28827 C        ET     = PE*SINTHE
28828          ET     = EKIN*SINTHE
28829 **
28830          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28831             ETA = -LOG(TAN(THETA/TWO))
28832          ELSE
28833             ETA = 100.0D0
28834          ENDIF
28835          THETA  = THETA/BOG
28836          LRNL   = .TRUE.
28837       ENDIF
28838
28839  9999 CONTINUE
28840       RETURN
28841       END
28842
28843 *$ CREATE DT_HIMULT.FOR
28844 *COPY DT_HIMULT
28845 *
28846 *===himult=============================================================*
28847 *
28848       SUBROUTINE DT_HIMULT(MODE)
28849
28850 ************************************************************************
28851 * Tables of average energies/multiplicities.                           *
28852 * This version dated 30.08.2000 is written by S. Roesler               *
28853 ************************************************************************
28854
28855       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28856       SAVE
28857
28858       PARAMETER ( LINP = 10 ,
28859      &            LOUT = 6 ,
28860      &            LDAT = 9 )
28861
28862       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28863
28864       PARAMETER (SWMEXP=1.7D0)
28865
28866       CHARACTER*8 ANAMEH(4)
28867
28868 * particle properties (BAMJET index convention)
28869       CHARACTER*8  ANAME
28870       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28871      &                IICH(210),IIBAR(210),K1(210),K2(210)
28872
28873 * temporary storage for one final state particle
28874       LOGICAL LFRAG,LGREY,LBLACK
28875       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28876      &                SINTHE,COSTHE,THETA,THECMS,
28877      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28878      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28879      &                LFRAG,LGREY,LBLACK
28880
28881 * event flag used for histograms
28882       COMMON /DTNORM/ ICEVT,IEVHKK
28883
28884 * Lorentz-parameters of the current interaction
28885       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28886      &                UMO,PPCM,EPROJ,PPROJ
28887
28888       PARAMETER (NOPART=210)
28889       DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
28890      &          AVPT(4,NOPART),IAVPT(4,NOPART)
28891       DATA ANAMEH /'DEUTERON','3-H     ','3-HE    ','4-HE    '/
28892
28893       GOTO (1,2,3) MODE
28894
28895 *------------------------------------------------------------------
28896 * initialization
28897     1 CONTINUE
28898       DO 10 I=1,NOPART
28899          DO 11 J=1,4
28900             AVMULT(J,I) = ZERO
28901             AVE(J,I)    = ZERO
28902             AVSWM(J,I)  = ZERO
28903             AVPT(J,I)   = ZERO
28904             IAVPT(J,I)  = 0
28905    11    CONTINUE
28906    10 CONTINUE
28907
28908       RETURN
28909
28910 *------------------------------------------------------------------
28911 * filling of histogram with event-record
28912     2 CONTINUE
28913       IF (PE.LT.0.0D0) THEN
28914          WRITE(LOUT,*) ' HIMULT:  PE < 0 ! ',PE
28915          RETURN
28916       ENDIF
28917       IF (.NOT.LFRAG) THEN
28918          IVEL = 2
28919          IF (LGREY)  IVEL = 3
28920          IF (LBLACK) IVEL = 4
28921          AVE(1,IDBJT)       = AVE(1,IDBJT)   +PE
28922          AVE(IVEL,IDBJT)    = AVE(IVEL,IDBJT)+PE
28923          AVPT(1,IDBJT)     = AVPT(1,IDBJT)   +PT
28924          AVPT(IVEL,IDBJT)  = AVPT(IVEL,IDBJT)+PT
28925          IAVPT(1,IDBJT)    = IAVPT(1,IDBJT)   +1
28926          IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
28927          AVSWM(1,IDBJT)     = AVSWM(1,IDBJT)   +PE**SWMEXP
28928          AVSWM(IVEL,IDBJT)  = AVSWM(IVEL,IDBJT)+PE**SWMEXP
28929          AVMULT(1,IDBJT)    = AVMULT(1,IDBJT)   +ONE
28930          AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
28931          IF (IDBJT.LT.116) THEN
28932 *   total energy, multiplicity
28933             AVE(1,30)       = AVE(1,30)   +PE
28934             AVE(IVEL,30)    = AVE(IVEL,30)+PE
28935             AVPT(1,30)     = AVPT(1,30)   +PT
28936             AVPT(IVEL,30)  = AVPT(IVEL,30)+PT
28937             IAVPT(1,30)    = IAVPT(1,30)   +1
28938             IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
28939             AVSWM(1,30)     = AVSWM(1,30)+PE**SWMEXP
28940             AVSWM(IVEL,30)  = AVSWM(IVEL,30)+PE**SWMEXP
28941             AVMULT(1,30)    = AVMULT(1,30)   +ONE
28942             AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
28943 *   charged energy, multiplicity
28944             IF (ICHAR.LT.0) THEN
28945                AVE(1,26)       = AVE(1,26)   +PE
28946                AVE(IVEL,26)    = AVE(IVEL,26)+PE
28947                AVPT(1,26)     = AVPT(1,26)   +PT
28948                AVPT(IVEL,26)  = AVPT(IVEL,26)+PT
28949                IAVPT(1,26)    = IAVPT(1,26)   +1
28950                IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
28951                AVSWM(1,26)     = AVSWM(1,26)   +PE**SWMEXP
28952                AVSWM(IVEL,26)  = AVSWM(IVEL,26)+PE**SWMEXP
28953                AVMULT(1,26)    = AVMULT(1,26)   +ONE
28954                AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
28955             ENDIF
28956             IF (ICHAR.NE.0) THEN
28957                AVE(1,27)       = AVE(1,27)   +PE
28958                AVE(IVEL,27)    = AVE(IVEL,27)+PE
28959                AVPT(1,27)     = AVPT(1,27)   +PT
28960                AVPT(IVEL,27)  = AVPT(IVEL,27)+PT
28961                IAVPT(1,27)    = IAVPT(1,27)   +1
28962                IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
28963                AVSWM(1,27)     = AVSWM(1,27)   +PE**SWMEXP
28964                AVSWM(IVEL,27)  = AVSWM(IVEL,27)+PE**SWMEXP
28965                AVMULT(1,27)    = AVMULT(1,27)   +ONE
28966                AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
28967             ENDIF
28968          ENDIF
28969       ENDIF
28970
28971       RETURN
28972
28973 *------------------------------------------------------------------
28974 * output
28975     3 CONTINUE
28976       WRITE(LOUT,3000)
28977  3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
28978      &       29X,'---------------------',/)
28979       IF (MULDEF.EQ.1) THEN
28980          WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
28981       ELSE
28982          BETGRE = 0.7D0
28983          BETBLC = 0.23D0
28984          WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
28985  3002    FORMAT(1X,'fast:  beta > ',F4.2,'    grey:  ',F4.2,' > beta > '
28986      &          ,F4.2,'    black:  beta < ',F4.2,/)
28987       ENDIF
28988       WRITE(LOUT,3003) SWMEXP
28989  3003 FORMAT(1X,'particle    |',12X,'average multiplicity',/,
28990      &      13X,'|     total         fast',
28991 C    &      '       grey     black      K      f(',F3.1,')',/,1X,
28992      &      '       grey     black    <pt>     f(',F3.1,')',/,1X,
28993      &      '------------+--------------',
28994      &      '-------------------------------------------------')
28995       DO 30 I=1,NOPART
28996          DO 31 J=1,4
28997             AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
28998             AVE(J,I)    = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
28999             AVPT(J,I)   = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29000             AVSWM(J,I)  = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29001    31    CONTINUE
29002          IF (I.LE.115) THEN
29003             WRITE(LOUT,3004) ANAME(I),I,
29004      &                       AVMULT(1,I),AVMULT(2,I),
29005      &                       AVMULT(3,I),AVMULT(4,I),
29006 C    &                       AVE(1,I),AVSWM(1,I)
29007      &                       AVPT(1,I),AVSWM(1,I)
29008          ELSEIF (I.LE.119) THEN
29009             WRITE(LOUT,3004) ANAMEH(I-115),I,
29010      &                       AVMULT(1,I),AVMULT(2,I),
29011      &                       AVMULT(3,I),AVMULT(4,I),
29012 C    &                       AVE(1,I),AVSWM(1,I)
29013      &                       AVPT(1,I),AVSWM(1,I)
29014          ENDIF
29015  3004    FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29016    30 CONTINUE
29017 **temporary
29018 C     WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29019 C    &               AVMULT(3,27)+AVMULT(4,27)
29020 **
29021
29022       RETURN
29023       END
29024
29025 *$ CREATE DT_HISTAT.FOR
29026 *COPY DT_HISTAT
29027 *
29028 *===histat=============================================================*
29029 *
29030       SUBROUTINE DT_HISTAT(IDX,MODE)
29031
29032 ************************************************************************
29033 * This version dated 26.02.96 is written by S. Roesler                 *
29034 *                                                                      *
29035 * Last change 27.12.2006 by S. Roesler.                                *
29036 ************************************************************************
29037
29038       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29039       SAVE
29040
29041       PARAMETER ( LINP = 10 ,
29042      &            LOUT = 6 ,
29043      &            LDAT = 9 )
29044
29045       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29046       PARAMETER (NDIM=199)
29047
29048 * event history
29049
29050       PARAMETER (NMXHKK=200000)
29051
29052       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29053      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29054      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29055
29056 * extended event history
29057       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29058      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29059      &                IHIST(2,NMXHKK)
29060
29061 * particle properties (BAMJET index convention)
29062       CHARACTER*8  ANAME
29063       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29064      &                IICH(210),IIBAR(210),K1(210),K2(210)
29065
29066       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29067
29068 * Glauber formalism: cross sections
29069       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29070      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29071      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29072      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29073      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29074      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29075      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29076      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29077      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29078      &                BSLOPE,NEBINI,NQBINI
29079
29080 * emulsion treatment
29081       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29082      &                NCOMPO,IEMUL
29083
29084 * properties of interacting particles
29085       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29086
29087 * rejection counter
29088       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29089      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29090      &                IREXCI(3),IRDIFF(2),IRINC
29091
29092 * statistics: residual nuclei
29093       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29094      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29095      &                NINCST(2,4),NINCEV(2),
29096      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29097      &                NRESPB(2),NRESCH(2),NRESEV(4),
29098      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29099      &                NEVAFI(2,2)
29100
29101 * parameter for intranuclear cascade
29102       LOGICAL LPAULI
29103       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29104
29105 *      INCLUDE '(DIMPAR)'
29106 *     Taken from FLUKA
29107       PARAMETER ( MXXRGN =20000 )
29108       PARAMETER ( MXXMDF =  710 )
29109       PARAMETER ( MXXMDE =  702 )
29110       PARAMETER ( MFSTCK =40000 )
29111       PARAMETER ( MESTCK =  100 )
29112       PARAMETER ( MOSTCK = 2000 )
29113       PARAMETER ( MXPRSN =  100 )
29114       PARAMETER ( MXPDPM =  800 )
29115       PARAMETER ( MXPSCS =30000 )
29116       PARAMETER ( MXGLWN =  300 )
29117       PARAMETER ( MXOUTU =   50 )
29118       PARAMETER ( NALLWP =   64 )
29119       PARAMETER ( NELEMX =   80 )
29120       PARAMETER ( MPDPDX =   18 )
29121       PARAMETER ( MXHTTR =  260 )
29122       PARAMETER ( MXSEAX =   20 )
29123       PARAMETER ( MXHTNC = MXSEAX + 1 )
29124       PARAMETER ( ICOMAX = 2400 )
29125       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
29126       PARAMETER ( NSTBIS =  304 )
29127       PARAMETER ( NQSTIS =   46 )
29128       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
29129       PARAMETER ( MXPABL =  120 )
29130       PARAMETER ( IDMAXP =  450 )
29131       PARAMETER ( IDMXDC = 2000 )
29132       PARAMETER ( MXMCIN =  410 )
29133       PARAMETER ( IHYPMX =    4 )
29134       PARAMETER ( MKBMX1 =   11 )
29135       PARAMETER ( MKBMX2 =   11 )
29136       PARAMETER ( MXIRRD = 2500 )
29137       PARAMETER ( MXTRDC = 1500 )
29138       PARAMETER ( NKTL   =   17 )
29139       PARAMETER ( NBLNMX = 40000000 )
29140
29141 *      INCLUDE '(PAREVT)'
29142 *     Taken from FLUKA
29143       PARAMETER ( FRDIFF = 0.2D+00 )
29144       PARAMETER ( ETHSEA = 1.0D+00 )
29145 *
29146       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29147      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
29148      &        LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
29149      &        LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
29150       COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
29151      &                  LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29152      &                  LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29153      &                  LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
29154      &                  LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
29155      &                  LVP2XX, LV2XNW, LNWV2X, LEVFIN
29156
29157 *      INCLUDE '(FRBKCM)'
29158 *     Taken from FLUKA
29159 *  Maximum number of fragments to be emitted:
29160       PARAMETER ( MXFFBK =     6 )
29161       PARAMETER ( MXZFBK =    10 )
29162       PARAMETER ( MXNFBK =    12 )
29163       PARAMETER ( MXAFBK =    16 )
29164       PARAMETER ( MXASST =    25 )
29165       PARAMETER ( NXAFBK = MXAFBK + 1 )
29166       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
29167       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
29168       PARAMETER ( MXPSST =   700 )
29169 *  Maximum number of pre-computed break-up combinations
29170       PARAMETER ( MXPPFB = 42500 )
29171 *  Maximum number of break-up combinations, including special
29172 *  run-time ones:
29173       PARAMETER ( MXPSFB = 43000 )
29174 *  Base for J multiplicity encoding:
29175       PARAMETER ( IBFRBK =    73 )
29176 *  Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
29177 *  it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
29178 *  ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
29179 *  --> Ibfrbk^(Jpwfbx+1) < 2100000000
29180       PARAMETER ( JPWFBX =     4 )
29181       LOGICAL LFRMBK, LNCMSS
29182       COMMON / FRBKCM /  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29183      &          WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
29184      &          SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
29185      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
29186      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
29187      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29188      &          IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
29189      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29190      &          IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
29191      &          IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
29192
29193 *      INCLUDE '(EVAFLG)'
29194 *     Taken from FLUKA
29195       LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29196      &        LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29197      &        LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29198      &        LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29199       COMMON / EVAFLG /     BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
29200      &        ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
29201      &        MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
29202      &        MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
29203      &        LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29204      &        LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29205      &        LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29206      &        LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29207
29208 * temporary storage for one final state particle
29209       LOGICAL LFRAG,LGREY,LBLACK
29210       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29211      &                SINTHE,COSTHE,THETA,THECMS,
29212      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29213      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29214      &                LFRAG,LGREY,LBLACK
29215
29216 * event flag used for histograms
29217       COMMON /DTNORM/ ICEVT,IEVHKK
29218
29219 * statistics: double-Pomeron exchange
29220       COMMON /DTFLG2/ INTFLG,IPOPO
29221
29222       DIMENSION EMUSAM(NCOMPX)
29223
29224       CHARACTER*13 CMSG(3)
29225       DATA CMSG /'not requested','not requested','not requested'/
29226
29227       GOTO (1,2,3,4,5) MODE
29228
29229 *------------------------------------------------------------------
29230 * initialization
29231     1 CONTINUE
29232 *  emulsion treatment
29233       IF (NCOMPO.GT.0) THEN
29234          DO 10 I=1,NCOMPX
29235             EMUSAM(I) = ZERO
29236    10    CONTINUE
29237       ENDIF
29238 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29239       NINCGE = 0
29240       DO 11 I=1,2
29241          EXCDPM(I)   = ZERO
29242          EXCDPM(I+2) = ZERO
29243          EXCEVA(I)   = ZERO
29244          NINCWO(I)   = 0
29245          NINCEV(I)   = 0
29246          NRESTO(I)   = 0
29247          NRESPR(I)   = 0
29248          NRESNU(I)   = 0
29249          NRESBA(I)   = 0
29250          NRESPB(I)   = 0
29251          NRESCH(I)   = 0
29252          NRESEV(I)   = 0
29253          NRESEV(I+2) = 0
29254          NEVAGA(I)   = 0
29255          NEVAHT(I)   = 0
29256          NEVAFI(1,I) = 0
29257          NEVAFI(2,I) = 0
29258          DO 12 J=1,6
29259             IF (J.LE.2) NINCHR(I,J) = 0
29260             IF (J.LE.3) NINCCO(I,J) = 0
29261             IF (J.LE.4) NINCST(I,J) = 0
29262             NEVA(I,J) = 0
29263    12    CONTINUE
29264          DO 13 J=1,210
29265             NEVAHY(1,I,J) = 0
29266             NEVAHY(2,I,J) = 0
29267    13    CONTINUE
29268    11 CONTINUE
29269       MAXGEN = 0
29270 **dble Po statistics.
29271       KPOPO = 0
29272
29273       RETURN
29274 *------------------------------------------------------------------
29275 * filling of histogram with event-record
29276     2 CONTINUE
29277       IF (IST.EQ.-1) THEN
29278          IF (.NOT.LFRAG) THEN
29279             IF (IDPDG.EQ.2212) THEN
29280                NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29281             ELSEIF (IDPDG.EQ.2112) THEN
29282                NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29283             ELSEIF (IDPDG.EQ.22) THEN
29284                NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29285             ELSEIF (IDPDG.EQ.80000) THEN
29286                IF (IDBJT.EQ.116) THEN
29287                   NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29288                ELSEIF (IDBJT.EQ.117) THEN
29289                   NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29290                ELSEIF (IDBJT.EQ.118) THEN
29291                   NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29292                ELSEIF (IDBJT.EQ.119) THEN
29293                   NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29294                ENDIF
29295             ENDIF
29296          ELSE
29297 *   heavy fragments (here: fission products only)
29298             NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29299             NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29300             NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29301          ENDIF
29302       ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29303          IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29304       ENDIF
29305
29306       RETURN
29307 *------------------------------------------------------------------
29308 * output
29309     3 CONTINUE
29310
29311 **dble Po statistics.
29312 C     WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29313 C    &   '# evts. / # dble-Po. evts / s_in / s_popo :',
29314 C    & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29315
29316 *  emulsion treatment
29317       IF (NCOMPO.GT.0) THEN
29318          WRITE(LOUT,3000)
29319  3000    FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29320      &          22X,'----------------------------',/,/,19X,
29321      &          'mass    charge          fraction',/,39X,
29322      &          'input     treated',/)
29323          DO 30 I=1,NCOMPO
29324             WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29325      &                       EMUSAM(I)/DBLE(ICEVT)
29326  3013       FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29327    30    CONTINUE
29328       ENDIF
29329
29330 *  i.n.c. statistics: output
29331       WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29332  3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29333      &       22X,'---------------------------------',/,/,1X,
29334      &       'no. of events for normalization: (accepted final events,',
29335      &       ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29336      &       /,1X,'no. of rejected events due to intranuclear',
29337      &       ' cascade',15X,I6,/)
29338       ICEV  = MAX(ICEVT,1)
29339       ICEV1 = ICEV
29340       IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29341       WRITE(LOUT,3002)
29342      &     (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29343      &     ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29344      &     KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29345      &    (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29346      &     (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29347      &     (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29348      &     (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29349  3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29350      &       5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29351      &       ' proj./ target (mean per evt)',/,8X,'baryons:  pos. ',
29352      &       F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,/,8X,
29353      &       'mesons:   pos. ',F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,
29354      &       /,1X,'maximum no. of generations treated (maximum allowed:'
29355      &       ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29356      &       ' interactions in proj./ target (mean per evt1)',
29357      &       F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29358      &       ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29359      &       'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29360      &       '(ap, K-, pi- only)     ',F7.3,' /',F7.3,/)
29361       WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29362      &                 IREXCI(1)+IREXCI(2)+IREXCI(3)
29363  3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29364      &       'evaporation',/,22X,'-----------------------------',
29365      &       '------------',/,/,1X,'no. of events for normal.: ',
29366      &       '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29367      &       ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29368      &       ' rejected events     (',I4,',',I4,',',I4,')',22X,I6,/)
29369
29370       WRITE(LOUT,3004)
29371  3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29372       ICEV  = MAX(NRESEV(2),1)
29373       WRITE(LOUT,3005)
29374      &     (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29375      &     (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29376      &     (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29377      &     (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29378      &     (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29379      &     (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29380      &     (EXCDPM(I)/DBLE(ICEV),I=1,2),
29381      &     (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29382  3005    FORMAT(1X,'residual nuclei:  (mean values per evt)',12X,
29383      &       'proj. / target',/,/,8X,'total number of particles',15X,
29384      &       2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29385      &       'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29386      &       'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29387      &       /,8X,'excitation energy (bef. evap.-step)   ',2E11.3,/,
29388      &       8X,'excitation energy per nucleon         ',2E11.3,/,/)
29389
29390 * evaporation / fission / fragmentation statistics: output
29391       ICEV  = MAX(NRESEV(2),1)
29392       ICEV1 = MAX(NRESEV(4),1)
29393       NTEVA1 =
29394      &   NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29395       NTEVA2 =
29396      &   NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29397       IF (LEVPRT) THEN
29398
29399          IF (IEVFSS.EQ.1) CMSG(1) = 'requested    '
29400
29401          IF (LFRMBK)     CMSG(2) = 'requested    '
29402          IF (LDEEXG)     CMSG(3) = 'requested    '
29403          WRITE(LOUT,3006)
29404      &        CMSG,
29405      &        DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29406      &        (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29407      &        (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29408      &        (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29409      &        (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29410      &        (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29411      &        (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29412      &        (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29413      &        (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29414  3006    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,'Fission:',
29415      &       13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29416      &       'deexcitation:',2X,A13,/,/,
29417      &       1X,'evaporation/deexcitation:  (mean values per evt1)  ',
29418      &       'proj. / target',/,/,8X,'total number of evap. particles',
29419      &       9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29420      &       'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29421      &       '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29422      &       2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29423      &       'heavy fragments',25X,2F9.3,/)
29424
29425          IF (IEVFSS.EQ.1) THEN
29426
29427             WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29428      &                       NEVAFI(2,1),NEVAFI(2,2),
29429      &             DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29430      &             DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29431  3007       FORMAT(1X,'Fission:   total number of events',14X,2I9,/
29432      &             12X,'out of which fission occured',8X,2I9,/,
29433      &             50X,'(',F5.2,'%) (',F5.2,'%)',/)
29434          ENDIF
29435
29436 C        IF ((LFRMBK).OR.(IEVFSS.EQ.1)) THEN
29437
29438 C           WRITE(LOUT,3008)
29439 C3008       FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29440 C    &             '       proj.   / target',/)
29441 C           DO 31 I=1,210
29442 C              IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29443 C                 WRITE(LOUT,3009) I,
29444 C    &            (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29445 C3009             FORMAT(38X,I3,3X,2E12.3)
29446 C              ENDIF
29447 C  31       CONTINUE
29448 C           WRITE(LOUT,3010)
29449 C3010       FORMAT(1X,'heavy fragments - statistics:',7X,'mass  ',
29450 C    &             '       proj.   / target',/)
29451 C           DO 32 I=1,210
29452 C              IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29453 C                 WRITE(LOUT,3011) I,
29454 C    &            (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29455 C3011             FORMAT(38X,I3,3X,2E12.3)
29456 C              ENDIF
29457 C  32       CONTINUE
29458 C           WRITE(LOUT,*)
29459 C        ENDIF
29460       ELSE
29461          WRITE(LOUT,3012)
29462  3012    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,
29463      &       'Evaporation:         not requested',/)
29464       ENDIF
29465
29466       RETURN
29467 *------------------------------------------------------------------
29468 * filling of histogram with event-record
29469     4 CONTINUE
29470 *  emulsion treatment
29471       IF (NCOMPO.GT.0) THEN
29472          DO 40 I=1,NCOMPO
29473             IF (IT.EQ.IEMUMA(I)) THEN
29474                EMUSAM(I) = EMUSAM(I)+ONE
29475             ENDIF
29476    40    CONTINUE
29477       ENDIF
29478       NINCGE = NINCGE+MAXGEN
29479       MAXGEN = 0
29480 **dble Po statistics.
29481       IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29482
29483       RETURN
29484 *------------------------------------------------------------------
29485 * filling of histogram with event-record
29486     5 CONTINUE
29487       IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29488          IB = IIBAR(IDBAM(IDX))
29489          IC = IICH(IDBAM(IDX))
29490          J  = ISTHKK(IDX)-14
29491          IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29492             NINCST(J,1) = NINCST(J,1)+1
29493          ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29494             NINCST(J,2) = NINCST(J,2)+1
29495          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29496             NINCST(J,3) = NINCST(J,3)+1
29497          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29498             NINCST(J,4) = NINCST(J,4)+1
29499          ENDIF
29500       ELSEIF (ISTHKK(IDX).EQ.17) THEN
29501          NINCWO(1) = NINCWO(1)+1
29502       ELSEIF (ISTHKK(IDX).EQ.18) THEN
29503          NINCWO(2) = NINCWO(2)+1
29504       ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29505          IB = IDRES(IDX)
29506          IC = IDXRES(IDX)
29507          IF (IC.GT.0) THEN
29508             NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29509             NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29510          ENDIF
29511          NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29512       ENDIF
29513
29514       RETURN
29515       END
29516 *$ CREATE DT_NEWHGR.FOR
29517 *COPY DT_NEWHGR
29518 *
29519 *===newhgr=============================================================*
29520 *
29521       SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29522
29523 ************************************************************************
29524 *                                                                      *
29525 *     Histogram initialization.                                        *
29526 *                                                                      *
29527 *     input:  XLIM1/XLIM2  lower/upper edge of histogram-window        *
29528 *             XLIM3        bin size                                    *
29529 *             IBIN    > 0  number of bins in equidistant lin. binning  *
29530 *                     = -1 reset histograms                            *
29531 *                     < -1 |IBIN| number of bins in equidistant log.   *
29532 *                          binning or log. binning in user def. struc. *
29533 *             XLIMB(*)     user defined bin structure                  *
29534 *                                                                      *
29535 *     The bin structure is sensitive to                                *
29536 *             XLIM1, XLIM3, IBIN     if     XLIM3 > 0   (lin.)         *
29537 *             XLIM1, XLIM2, IBIN     if     XLIM3 = 0   (lin. & log.)  *
29538 *             XLIMB, IBIN            if     XLIM3 < 0                  *
29539 *                                                                      *
29540 *                                                                      *
29541 *     output: IREFN        histogram index                             *
29542 *                          (= -1 for inconsistent histogr. request)    *
29543 *                                                                      *
29544 * This subroutine is based on a original version by R. Engel.          *
29545 * This version dated 22.4.95 is written  by S. Roesler.                *
29546 ************************************************************************
29547
29548       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29549       SAVE
29550
29551       PARAMETER ( LINP = 10 ,
29552      &            LOUT = 6 ,
29553      &            LDAT = 9 )
29554
29555       LOGICAL LSTART
29556
29557       PARAMETER (ZERO   =  0.0D0,
29558      &           TINY   =  1.0D-10)
29559
29560       DIMENSION XLIMB(*)
29561
29562 * histograms
29563
29564       PARAMETER (NHIS=150, NDIM=250)
29565
29566       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29567      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29568
29569 * auxiliary common for histograms
29570       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29571
29572       DATA LSTART /.TRUE./
29573
29574 * reset histogram counter
29575       IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29576          IHISL  = 0
29577          IF (IBIN.EQ.-1) RETURN
29578          LSTART = .FALSE.
29579       ENDIF
29580
29581       IHIS  = IHISL+1
29582 * check for maximum number of allowed histograms
29583       IF (IHIS.GT.NHIS) THEN
29584          WRITE(LOUT,1003) IHIS,NHIS,IHIS
29585  1003    FORMAT(1X,'NEWHGR:   warning!  number of histograms (',
29586      &          I4,') exceeds array size (',I4,')',/,21X,
29587      &          'histogram',I3,' skipped!')
29588          GOTO 9999
29589       ENDIF
29590
29591       IREFN = IHIS
29592       IBINS(IHIS) = ABS(IBIN)
29593 * check requested number of bins
29594       IF (IBINS(IHIS).GE.NDIM) THEN
29595          WRITE(LOUT,1000) IBIN,NDIM,NDIM
29596  1000    FORMAT(1X,'NEWHGR:   warning!  number of bins (',
29597      &          I3,') exceeds array size (',I3,')',/,21X,
29598      &          'and will be reset to ',I3)
29599          IBINS(IHIS) = NDIM
29600       ENDIF
29601       IF (IBINS(IHIS).EQ.0) THEN
29602          WRITE(LOUT,1001) IBIN,IHIS
29603  1001    FORMAT(1X,'NEWHGR:   warning!  inconsistent number of',
29604      &          ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29605          GOTO 9999
29606       ENDIF
29607
29608 * initialize arrays
29609       DO 1 I=1,NDIM
29610          DO 2 K=1,3
29611             HIST(K,IHIS,I)   = ZERO
29612             HIST(K+3,IHIS,I) = ZERO
29613             TMPHIS(K,IHIS,I) = ZERO
29614     2    CONTINUE
29615          HIST(7,IHIS,I)   = ZERO
29616     1 CONTINUE
29617       DENTRY(1,IHIS)= ZERO
29618       DENTRY(2,IHIS)= ZERO
29619       OVERF(IHIS)   = ZERO
29620       UNDERF(IHIS)  = ZERO
29621       TMPUFL(IHIS)  = ZERO
29622       TMPOFL(IHIS)  = ZERO
29623
29624 * bin str. sensitive to lower edge, bin size, and numb. of bins
29625       IF (XLIM3.GT.ZERO) THEN
29626          DO 3 K=1,IBINS(IHIS)+1
29627             HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29628     3    CONTINUE
29629          ISWI(IHIS) = 1
29630 * bin str. sensitive to lower/upper edge and numb. of bins
29631       ELSEIF (XLIM3.EQ.ZERO) THEN
29632 *   linear binning
29633          IF (IBIN.GT.0) THEN
29634             XLOW = XLIM1
29635             XHI  = XLIM2
29636             IF (XLIM2.LE.XLIM1) THEN
29637                WRITE(LOUT,1002) XLIM1,XLIM2
29638  1002          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29639      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29640                GOTO 9999
29641             ENDIF
29642             ISWI(IHIS) = 1
29643          ELSEIF (IBIN.LT.-1) THEN
29644 *   logarithmic binning
29645             IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29646                WRITE(LOUT,1004) XLIM1,XLIM2
29647  1004          FORMAT(1X,'NEWHGR:   warning!  inconsistent log. ',
29648      &                'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29649                GOTO 9999
29650             ENDIF
29651             IF (XLIM2.LE.XLIM1) THEN
29652                WRITE(LOUT,1005) XLIM1,XLIM2
29653  1005          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29654      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29655                GOTO 9999
29656             ENDIF
29657             XLOW = LOG10(XLIM1)
29658             XHI  = LOG10(XLIM2)
29659             ISWI(IHIS) = 3
29660          ENDIF
29661          DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29662          DO 4 K=1,IBINS(IHIS)+1
29663             HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29664     4    CONTINUE
29665       ELSE
29666 * user defined bin structure
29667          DO 5 K=1,IBINS(IHIS)+1
29668             IF (IBIN.GT.0) THEN
29669                HIST(1,IHIS,K) = XLIMB(K)
29670                ISWI(IHIS) = 2
29671             ELSEIF (IBIN.LT.-1) THEN
29672                HIST(1,IHIS,K) = LOG10(XLIMB(K))
29673                ISWI(IHIS) = 4
29674             ENDIF
29675     5    CONTINUE
29676       ENDIF
29677
29678 * histogram accepted
29679       IHISL = IHIS
29680
29681       RETURN
29682
29683  9999 CONTINUE
29684       IREFN = -1
29685       RETURN
29686       END
29687
29688 *$ CREATE DT_FILHGR.FOR
29689 *COPY DT_FILHGR
29690 *
29691 *===filhgr=============================================================*
29692 *
29693       SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29694
29695 ************************************************************************
29696 *                                                                      *
29697 *     Scoring for histogram IHIS.                                      *
29698 *                                                                      *
29699 * This subroutine is based on a original version by R. Engel.          *
29700 * This version dated 23.4.95 is written  by S. Roesler.                *
29701 ************************************************************************
29702
29703       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29704       SAVE
29705
29706       PARAMETER ( LINP = 10 ,
29707      &            LOUT = 6 ,
29708      &            LDAT = 9 )
29709
29710       PARAMETER (ZERO = 0.0D0,
29711      &           ONE  = 1.0D0,
29712      &           TINY = 1.0D-10)
29713
29714 * histograms
29715
29716       PARAMETER (NHIS=150, NDIM=250)
29717
29718       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29719      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29720
29721 * auxiliary common for histograms
29722       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29723
29724       DATA NCEVT /1/
29725
29726       X = XI
29727       Y = YI
29728
29729 * dump content of temorary arrays into histograms
29730       IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29731          CALL DT_EVTHIS(IDUM)
29732          NCEVT = NEVT
29733       ENDIF
29734
29735 * check histogram index
29736       IF (IHIS.EQ.-1) RETURN
29737       IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29738 C        WRITE(LOUT,1000) IHIS,IHISL
29739  1000    FORMAT(1X,'FILHGR:   warning!  histogram index',I4,
29740      &          ' out of range (1..',I3,')')
29741          RETURN
29742       ENDIF
29743
29744       IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29745 * bin structure not explicitly given
29746          IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29747          DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29748          IF (X.LT.HIST(1,IHIS,1)) THEN
29749             I1 = 0
29750          ELSE
29751             I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29752          ENDIF
29753
29754       ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29755 * user defined bin structure
29756          IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29757          IF (X.LT.HIST(1,IHIS,1)) THEN
29758             I1 = 0
29759          ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29760             I1 = IBINS(IHIS)+1
29761          ELSE
29762 *   binary sort algorithm
29763             KMIN = 0
29764             KMAX = IBINS(IHIS)+1
29765     1       CONTINUE
29766             IF ((KMAX-KMIN).EQ.1) GOTO 2
29767             KK = (KMAX+KMIN)/2
29768             IF (X.LE.HIST(1,IHIS,KK)) THEN
29769                KMAX=KK
29770             ELSE
29771                KMIN=KK
29772             ENDIF
29773             GOTO 1
29774     2       CONTINUE
29775             I1 = KMIN
29776          ENDIF
29777
29778       ELSE
29779          WRITE(LOUT,1001)
29780  1001    FORMAT(1X,'FILHGR:   warning!  histogram not initialized')
29781          RETURN
29782       ENDIF
29783
29784 * scoring
29785       IF (I1.LE.0) THEN
29786          TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29787       ELSEIF (I1.LE.IBINS(IHIS)) THEN
29788          TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29789          IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29790             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29791          ELSE
29792             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29793          ENDIF
29794          TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29795       ELSE
29796          TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29797       ENDIF
29798
29799       RETURN
29800       END
29801
29802 *$ CREATE DT_EVTHIS.FOR
29803 *COPY DT_EVTHIS
29804 *
29805 *===evthis=============================================================*
29806 *
29807       SUBROUTINE DT_EVTHIS(NEVT)
29808
29809 ************************************************************************
29810 * Dump content of temorary histograms into /DTHIS1/. This subroutine   *
29811 * is called after each event and for the last event before any call    *
29812 * to OUTHGR.                                                           *
29813 *         NEVT   number of events dumped, this is only needed to       *
29814 *                get the normalization after the last event            *
29815 * This version dated 23.4.95 is written  by S. Roesler.                *
29816 ************************************************************************
29817
29818       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29819       SAVE
29820
29821       PARAMETER ( LINP = 10 ,
29822      &            LOUT = 6 ,
29823      &            LDAT = 9 )
29824
29825       LOGICAL LNOETY
29826
29827       PARAMETER (ZERO = 0.0D0,
29828      &           ONE  = 1.0D0,
29829      &           TINY = 1.0D-10)
29830
29831 * histograms
29832
29833       PARAMETER (NHIS=150, NDIM=250)
29834
29835       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29836      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29837
29838 * auxiliary common for histograms
29839       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29840
29841       DATA NCEVT /0/
29842
29843       NCEVT = NCEVT+1
29844       NEVT  = NCEVT
29845
29846       DO 1 I=1,IHISL
29847          LNOETY = .TRUE.
29848          DO 2 J=1,IBINS(I)
29849             IF (TMPHIS(1,I,J).GT.ZERO) THEN
29850                LNOETY = .FALSE.
29851                HIST(2,I,J)   = HIST(2,I,J)+ONE
29852                HIST(7,I,J)   = HIST(7,I,J)+TMPHIS(1,I,J)
29853                DENTRY(2,I)   = DENTRY(2,I)+TMPHIS(1,I,J)
29854                AVX           = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29855                HIST(3,I,J)   = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29856                HIST(4,I,J)   = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29857                HIST(5,I,J)   = HIST(5,I,J)+TMPHIS(3,I,J)
29858                HIST(6,I,J)   = HIST(6,I,J)+TMPHIS(3,I,J)**2
29859                TMPHIS(1,I,J) = ZERO
29860                TMPHIS(2,I,J) = ZERO
29861                TMPHIS(3,I,J) = ZERO
29862             ENDIF
29863     2    CONTINUE
29864          IF (LNOETY) THEN
29865             IF (TMPUFL(I).GT.ZERO) THEN
29866                UNDERF(I) = UNDERF(I)+ONE
29867                TMPUFL(I) = ZERO
29868             ELSEIF (TMPOFL(I).GT.ZERO) THEN
29869                OVERF(I)  = OVERF(I)+ONE
29870                TMPOFL(I) = ZERO
29871             ENDIF
29872          ELSE
29873             DENTRY(1,I) = DENTRY(1,I)+ONE
29874          ENDIF
29875     1 CONTINUE
29876
29877       RETURN
29878       END
29879
29880 *$ CREATE DT_OUTHGR.FOR
29881 *COPY DT_OUTHGR
29882 *
29883 *===outhgr=============================================================*
29884 *
29885       SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29886      &                  ILOGY,INORM,NMODE)
29887
29888 ************************************************************************
29889 *                                                                      *
29890 *     Plot histogram(s) to standard output unit                        *
29891 *                                                                      *
29892 *         I1..6         indices of histograms to be plotted            *
29893 *         CHEAD,IHEAD   header string,integer                          *
29894 *         NEVTS         number of events                               *
29895 *         FAC           scaling factor                                 *
29896 *         ILOGY   = 1   logarithmic y-axis                             *
29897 *         INORM         normalization                                  *
29898 *                 = 0   no further normalization (FAC is obsolete)     *
29899 *                 = 1   per event and bin width                        *
29900 *                 = 2   per entry and bin width                        *
29901 *                 = 3   per bin entry                                  *
29902 *                 = 4   per event and "bin width" x1^2...x2^2          *
29903 *                 = 5   per event and "log. bin width" ln x1..ln x2    *
29904 *                 = 6   per event                                      *
29905 *         MODE    = 0   no output but normalization applied            *
29906 *                 = 1   all valid histograms separately (small frame)  *
29907 *                       all valid histograms separately (small frame)  *
29908 *                 = -1  and tables as histograms                       *
29909 *                 = 2   all valid histograms (one plot, wide frame)    *
29910 *                       all valid histograms (one plot, wide frame)    *
29911 *                 = -2  and tables as histograms                       *
29912 *                                                                      *
29913 *                                                                      *
29914 *     Note: All histograms to be plotted with one call to this         *
29915 *           subroutine and |MODE|=2 must have the same bin structure!  *
29916 *           There is no test included ensuring this fact.              *
29917 *                                                                      *
29918 * This version dated 23.4.95 is written  by S. Roesler.                *
29919 ************************************************************************
29920
29921       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29922       SAVE
29923
29924       PARAMETER ( LINP = 10 ,
29925      &            LOUT = 6 ,
29926      &            LDAT = 9 )
29927
29928       CHARACTER*72 CHEAD
29929
29930       PARAMETER (ZERO   =  0.0D0,
29931      &           IZERO  =  0,
29932      &           ONE    =  1.0D0,
29933      &           TWO    =  2.0D0,
29934      &           OHALF  =  0.5D0,
29935      &           EPS    =  1.0D-5,
29936      &           TINY   =  1.0D-8,
29937      &           SMALL  =  -1.0D8,
29938      &           RLARGE =  1.0D8 )
29939
29940 * histograms
29941
29942       PARAMETER (NHIS=150, NDIM=250)
29943
29944       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29945      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29946
29947       PARAMETER (NDIM2 = 2*NDIM)
29948       DIMENSION XX(NDIM2),YY(NDIM2)
29949
29950       PARAMETER (NHISTO = 6)
29951       DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
29952      &          IDX(NHISTO)
29953
29954       CHARACTER*43 CNORM(0:8)
29955       DATA CNORM /'no further normalization                   ',
29956      &            'per event and bin width                    ',
29957      &            'per entry1 and bin width                   ',
29958      &            'per bin entry                              ',
29959      &            'per event and "bin width" x1^2...x2^2      ',
29960      &            'per event and "log. bin width" ln x1..ln x2',
29961      &            'per event                                  ',
29962      &            'per bin entry1                             ',
29963      &            'per entry2 and bin width                   '/
29964
29965       IDX1(1) = I1
29966       IDX1(2) = I2
29967       IDX1(3) = I3
29968       IDX1(4) = I4
29969       IDX1(5) = I5
29970       IDX1(6) = I6
29971
29972       MODE = NMODE
29973
29974 * initialization if "wide frame" is requested
29975       IF (ABS(MODE).EQ.2) THEN
29976          DO 1 I=1,NHISTO
29977             DO 2 J=1,NDIM
29978                XX1(J,I) = ZERO
29979                YY1(J,I) = ZERO
29980     2       CONTINUE
29981     1    CONTINUE
29982       ENDIF
29983
29984 * plot header
29985       WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
29986
29987 * check histogram indices
29988       NHI = 0
29989       DO 3 I=1,NHISTO
29990          IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
29991             IF (ISWI(IDX1(I)).NE.0) THEN
29992                IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
29993                   WRITE(LOUT,1000)
29994      &                 IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
29995  1000             FORMAT(/,1X,'OUTHGR:   warning!  no entries in',
29996      &                   ' histogram ',I3,/,21X,'underflows:',F10.0,
29997      &                   '   overflows:  ',F10.0)
29998                ELSE
29999                   NHI = NHI+1
30000                   IDX(NHI) = IDX1(I)
30001                ENDIF
30002             ENDIF
30003          ENDIF
30004     3 CONTINUE
30005       IF (NHI.EQ.0) THEN
30006          WRITE(LOUT,1001)
30007  1001    FORMAT(/,1X,'OUTHGR:   warning!  histogram indices not valid')
30008          RETURN
30009       ENDIF
30010
30011 * check normalization request
30012       IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30013      &     ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30014      &                        (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30015      &     (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30016          WRITE(LOUT,1002) NEVTS,INORM,FAC
30017  1002    FORMAT(/,1X,'OUTHGR:   warning!  normalization request not ',
30018      &          'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30019      &          'FAC = ',E11.4)
30020          RETURN
30021       ENDIF
30022
30023       WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30024
30025 * apply normalization
30026       DO 4 N=1,NHI
30027
30028          I = IDX(N)
30029
30030          IF (ISWI(I).EQ.1) THEN
30031             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30032  1003       FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30033      &             ' to',2X,E10.4,',',2X,I3,' bins')
30034          ELSEIF (ISWI(I).EQ.2) THEN
30035             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30036             WRITE(LOUT,1007)
30037  1007       FORMAT(1X,'user defined bin structure')
30038          ELSEIF (ISWI(I).EQ.3) THEN
30039             WRITE(LOUT,1004)
30040      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30041  1004       FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30042      &             ' to',2X,E10.4,',',2X,I3,' bins')
30043          ELSEIF (ISWI(I).EQ.4) THEN
30044             WRITE(LOUT,1004)
30045      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30046             WRITE(LOUT,1007)
30047          ELSE
30048             WRITE(LOUT,1008) ISWI(I)
30049  1008       FORMAT(/,1X,'warning!  inconsistent bin structure flag ',I4)
30050          ENDIF
30051          WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30052  1005    FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30053      &          ' overfl.:',F8.0)
30054          WRITE(LOUT,1009) CNORM(INORM)
30055  1009    FORMAT(1X,'normalization: ',A,/)
30056
30057          DO 5 K=1,IBINS(I)
30058             CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30059             YMEAN = FAC*YMEAN
30060             YERR  = FAC*YERR
30061             WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30062             WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30063  1006       FORMAT(1X,5E11.3)
30064 *    small frame
30065             II = 2*K
30066             XX(II-1) = HIST(1,I,K)
30067             XX(II)   = HIST(1,I,K+1)
30068             YY(II-1) = YMEAN
30069             YY(II)   = YMEAN
30070 *    wide frame
30071             XX1(K,N) = XMEAN
30072             IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30073      &         XX1(K,N) = LOG10(XMEAN)
30074             YY1(K,N) = YMEAN
30075     5    CONTINUE
30076
30077 * plot small frame
30078          IF (ABS(MODE).EQ.1) THEN
30079             IBIN2 = 2*IBINS(I)
30080             WRITE(LOUT,'(/,1X,A)') 'Preview:'
30081             IF(ILOGY.EQ.1) THEN
30082               CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30083             ELSE
30084               CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30085             ENDIF
30086          ENDIF
30087
30088     4 CONTINUE
30089
30090 * plot wide frame
30091       IF (ABS(MODE).EQ.2) THEN
30092          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30093          NSIZE = NDIM*NHISTO
30094          DXLOW = HIST(1,IDX(1),1)
30095          DDX   = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30096          YLOW  = RLARGE
30097          YHI   = SMALL
30098          DO 6 I=1,NHISTO
30099             DO 7 J=1,NDIM
30100                IF (YY1(J,I).LT.YLOW) THEN
30101                   IF (ILOGY.EQ.1) THEN
30102                      IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30103                   ELSE
30104                      YLOW = YY1(J,I)
30105                   ENDIF
30106                ENDIF
30107                IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30108     7       CONTINUE
30109     6    CONTINUE
30110          DY = (YHI-YLOW)/DBLE(NDIM)
30111          IF (DY.LE.ZERO) THEN
30112             WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30113      &         'OUTHGR:   warning! zero bin width for histograms ',
30114      &         IDX,': ',YLOW,YHI
30115             RETURN
30116          ENDIF
30117          IF (ILOGY.EQ.1) THEN
30118             YLOW = LOG10(YLOW)
30119             DY   = (LOG10(YHI)-YLOW)/100.0D0
30120             DO 8 I=1,NHISTO
30121                DO 9 J=1,NDIM
30122                   IF (YY1(J,I).LE.ZERO) THEN
30123                      YY1(J,I) = YLOW
30124                   ELSE
30125                      YY1(J,I) = LOG10(YY1(J,I))
30126                   ENDIF
30127     9          CONTINUE
30128     8       CONTINUE
30129          ENDIF
30130          CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30131       ENDIF
30132
30133       RETURN
30134       END
30135
30136 *$ CREATE DT_GETBIN.FOR
30137 *COPY DT_GETBIN
30138 *
30139 *===getbin=============================================================*
30140 *
30141       SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30142      &                  XMEAN,YMEAN,YERR)
30143
30144 ************************************************************************
30145 * This version dated 23.4.95 is written  by S. Roesler.                *
30146 ************************************************************************
30147
30148       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30149       SAVE
30150
30151       PARAMETER ( LINP = 10 ,
30152      &            LOUT = 6 ,
30153      &            LDAT = 9 )
30154
30155       PARAMETER (ZERO   = 0.0D0,
30156      &           ONE    = 1.0D0,
30157      &           TINY35 = 1.0D-35)
30158
30159 * histograms
30160
30161       PARAMETER (NHIS=150, NDIM=250)
30162
30163       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30164      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30165
30166       XLOW = HIST(1,IHIS,IBIN)
30167       XHI  = HIST(1,IHIS,IBIN+1)
30168       IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30169          XLOW = 10**XLOW
30170          XHI  = 10**XHI
30171       ENDIF
30172       IF (NORM.EQ.2) THEN
30173          DX   = XHI-XLOW
30174          NEVT = INT(DENTRY(1,IHIS))
30175       ELSEIF (NORM.EQ.3) THEN
30176          DX   = ONE
30177          NEVT = INT(HIST(2,IHIS,IBIN))
30178       ELSEIF (NORM.EQ.4) THEN
30179          DX   = XHI**2-XLOW**2
30180          NEVT = KEVT
30181       ELSEIF (NORM.EQ.5) THEN
30182          DX   = LOG(ABS(XHI))-LOG(ABS(XLOW))
30183          NEVT = KEVT
30184       ELSEIF (NORM.EQ.6) THEN
30185          DX   = ONE
30186          NEVT = KEVT
30187       ELSEIF (NORM.EQ.7) THEN
30188          DX   = ONE
30189          NEVT = INT(HIST(7,IHIS,IBIN))
30190       ELSEIF (NORM.EQ.8) THEN
30191          DX   = XHI-XLOW
30192          NEVT = INT(DENTRY(2,IHIS))
30193       ELSE
30194          DX   = ABS(XHI-XLOW)
30195          NEVT = KEVT
30196       ENDIF
30197       IF (ABS(DX).LT.TINY35) DX = ONE
30198       NEVT   = MAX(NEVT,1)
30199       YMEAN  = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30200       YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30201       YERR   = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30202       YSUM   = HIST(5,IHIS,IBIN)
30203       IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30204 C     XMEAN  = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30205       XMEAN  = HIST(3,IHIS,IBIN)/YSUM
30206       IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30207
30208       RETURN
30209       END
30210
30211 *$ CREATE DT_JOIHIS.FOR
30212 *COPY DT_JOIHIS
30213 *
30214 *===joihis=============================================================*
30215 *
30216       SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30217
30218 ************************************************************************
30219 *                                                                      *
30220 *     Operation on histograms.                                         *
30221 *                                                                      *
30222 *     input:  IH1,IH2      histogram indices to be joined              *
30223 *             COPER        character defining the requested operation, *
30224 *                          i.e. '+', '-', '*', '/'                     *
30225 *             FAC1,FAC2    factors for joining, i.e.                   *
30226 *                          FAC1*histo1 COPER FAC2*histo2               *
30227 *                                                                      *
30228 * This version dated 23.4.95 is written  by S. Roesler.                *
30229 ************************************************************************
30230
30231       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30232       SAVE
30233
30234       PARAMETER ( LINP = 10 ,
30235      &            LOUT = 6 ,
30236      &            LDAT = 9 )
30237
30238       CHARACTER COPER*1
30239
30240       PARAMETER (ZERO   =  0.0D0,
30241      &           ONE    =  1.0D0,
30242      &           OHALF  =  0.5D0,
30243      &           TINY8  =  1.0D-8,
30244      &           SMALL  =  -1.0D8,
30245      &           RLARGE =  1.0D8 )
30246
30247 * histograms
30248
30249       PARAMETER (NHIS=150, NDIM=250)
30250
30251       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30252      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30253
30254       PARAMETER (NDIM2 = 2*NDIM)
30255       DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30256
30257       CHARACTER*43 CNORM(0:6)
30258       DATA CNORM /'no further normalization                   ',
30259      &            'per event and bin width                    ',
30260      &            'per entry and bin width                    ',
30261      &            'per bin entry                              ',
30262      &            'per event and "bin width" x1^2...x2^2      ',
30263      &            'per event and "log. bin width" ln x1..ln x2',
30264      &            'per event                                  '/
30265
30266 * check histogram indices
30267       IF ((IH1.LT.    1).OR.(IH2.LT.    1).OR.
30268      &    (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30269          WRITE(LOUT,1000) IH1,IH2,IHISL
30270  1000    FORMAT(1X,'JOIHIS:   warning!  inconsistent histogram ',
30271      &          'indices (',I3,',',I3,'),',/,21X,'valid range:  1,',I3)
30272          GOTO 9999
30273       ENDIF
30274
30275 * check bin structure of histograms to be joined
30276       IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30277          WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30278  1001    FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30279      &          ' and ',I3,' failed',/,21X,
30280      &          'due to different numbers of bins (',I3,',',I3,')')
30281          GOTO 9999
30282       ENDIF
30283       DO 1 K=1,IBINS(IH1)+1
30284          IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30285             WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30286  1002       FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30287      &             ' and ',I3,' failed at bin edge ',I3,/,21X,
30288      &             'X1,X2 = ',2E11.4)
30289             GOTO 9999
30290          ENDIF
30291     1 CONTINUE
30292
30293       WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30294  1003 FORMAT(1X,'JOIHIS:   joining histograms ',I3,',',I3,' with ',
30295      &       'operation ',A,/,11X,'and factors ',2E11.4)
30296       WRITE(LOUT,1004) CNORM(NORM)
30297  1004 FORMAT(1X,'normalization: ',A,/)
30298
30299       DO 2 K=1,IBINS(IH1)
30300          CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30301          CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30302          XLOW  = XLOW1
30303          XHI   = XHI1
30304          XMEAN = OHALF*(XMEAN1+XMEAN2)
30305          IF (COPER.EQ.'+') THEN
30306             YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30307          ELSEIF (COPER.EQ.'*') THEN
30308             YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30309          ELSEIF (COPER.EQ.'/') THEN
30310             IF (YMEAN2.EQ.ZERO) THEN
30311                YMEAN = ZERO
30312             ELSE
30313                IF (FAC2.EQ.ZERO) FAC2 = ONE
30314                YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30315             ENDIF
30316          ELSE
30317             GOTO 9998
30318          ENDIF
30319          WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30320          WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30321  1006    FORMAT(1X,5E11.3)
30322 *    small frame
30323          II = 2*K
30324          XX(II-1) = HIST(1,IH1,K)
30325          XX(II)   = HIST(1,IH1,K+1)
30326          YY(II-1) = YMEAN
30327          YY(II)   = YMEAN
30328 *    wide frame
30329          XX1(K) = XMEAN
30330          IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30331          YY1(K) = YMEAN
30332     2 CONTINUE
30333
30334 * plot small frame
30335       IF (ABS(MODE).EQ.1) THEN
30336          IBIN2 = 2*IBINS(IH1)
30337          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30338          IF(ILOGY.EQ.1) THEN
30339            CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30340          ELSE
30341            CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30342          ENDIF
30343       ENDIF
30344
30345 * plot wide frame
30346       IF (ABS(MODE).EQ.2) THEN
30347          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30348          NSIZE = NDIM
30349          DXLOW = HIST(1,IH1,1)
30350          DDX   = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30351          YLOW  = RLARGE
30352          YHI   = SMALL
30353          DO 3 I=1,NDIM
30354             IF (YY1(I).LT.YLOW) THEN
30355                IF (ILOGY.EQ.1) THEN
30356                   IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30357                ELSE
30358                   YLOW = YY1(I)
30359                ENDIF
30360             ENDIF
30361             IF (YY1(I).GT.YHI) YHI = YY1(I)
30362     3    CONTINUE
30363          DY = (YHI-YLOW)/DBLE(NDIM)
30364          IF (DY.LE.ZERO) THEN
30365             WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30366      &         'JOIHIS:   warning! zero bin width for histograms ',
30367      &         IH1,IH2,': ',YLOW,YHI
30368             RETURN
30369          ENDIF
30370          IF (ILOGY.EQ.1) THEN
30371             YLOW = LOG10(YLOW)
30372             DY   = (LOG10(YHI)-YLOW)/100.0D0
30373             DO 4 I=1,NDIM
30374                IF (YY1(I).LE.ZERO) THEN
30375                   YY1(I) = YLOW
30376                ELSE
30377                   YY1(I) = LOG10(YY1(I))
30378                ENDIF
30379     4       CONTINUE
30380          ENDIF
30381          CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30382       ENDIF
30383
30384       RETURN
30385
30386  9998 CONTINUE
30387       WRITE(LOUT,1005) COPER
30388  1005 FORMAT(1X,'JOIHIS:   unknown operation ',A)
30389
30390  9999 CONTINUE
30391       RETURN
30392       END
30393
30394 *$ CREATE DT_XGRAPH.FOR
30395 *COPY DT_XGRAPH
30396 *
30397 *===qgraph=============================================================*
30398 *
30399       SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30400 C***********************************************************************
30401 C
30402 C     calculate quasi graphic picture with 25 lines and 79 columns
30403 C     ranges will be chosen automatically
30404 C
30405 C     input     N          dimension of input fields
30406 C               IARG       number of curves (fields) to plot
30407 C               X          field of X
30408 C               Y1         field of Y1
30409 C               Y2         field of Y2
30410 C
30411 C This subroutine is written by R. Engel.
30412 C***********************************************************************
30413       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30414       SAVE
30415
30416       PARAMETER ( LINP = 10 ,
30417      &            LOUT = 6 ,
30418      &            LDAT = 9 )
30419
30420 C
30421       DIMENSION X(N),Y1(N),Y2(N)
30422       PARAMETER (EPS=1.D-30)
30423       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30424       CHARACTER SYMB(5)
30425       CHARACTER COL(0:149,0:49)
30426 C
30427       DATA SYMB /'0','e','z','#','x'/
30428 C
30429       ISPALT=IBREIT-10
30430 C
30431 C***  automatic range fitting
30432 C
30433       XMAX=X(1)
30434       XMIN=X(1)
30435       DO 600 I=1,N
30436          XMAX=MAX(X(I),XMAX)
30437          XMIN=MIN(X(I),XMIN)
30438  600  CONTINUE
30439       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30440 C
30441       ITEST=0
30442       DO 1100 K=0,IZEIL-1
30443          ITEST=ITEST+1
30444          IF (ITEST.EQ.IYRAST) THEN
30445             DO 1010 L=1,ISPALT-1
30446                COL(L,K)='-'
30447 1010        CONTINUE
30448             COL(ISPALT,K)='+'
30449             ITEST=0
30450             DO 1020 L=0,ISPALT-1,IXRAST
30451                COL(L,K)='+'
30452 1020        CONTINUE
30453          ELSE
30454             DO 1030 L=1,ISPALT-1
30455                COL(L,K)=' '
30456 1030        CONTINUE
30457             DO 1040 L=0,ISPALT-1,IXRAST
30458                COL(L,K)='|'
30459 1040        CONTINUE
30460             COL(ISPALT,K)='|'
30461          ENDIF
30462 1100  CONTINUE
30463 C
30464 C***  plot curve Y1
30465 C
30466       YMAX=Y1(1)
30467       YMIN=Y1(1)
30468       DO 500 I=1,N
30469          YMAX=MAX(Y1(I),YMAX)
30470          YMIN=MIN(Y1(I),YMIN)
30471 500   CONTINUE
30472       IF(IARG.GT.1) THEN
30473         DO 550 I=1,N
30474            YMAX=MAX(Y2(I),YMAX)
30475            YMIN=MIN(Y2(I),YMIN)
30476 550     CONTINUE
30477       ENDIF
30478       YMAX=(YMAX-YMIN)/40.0D0+YMAX
30479       YMIN=YMIN-(YMAX-YMIN)/40.0D0
30480       YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30481       IF(YZOOM.LT.EPS) THEN
30482         WRITE(LOUT,'(1X,A)')
30483      &    'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30484         RETURN
30485       ENDIF
30486 C
30487 C***  plot curve Y1
30488 C
30489       ILAST=-1
30490       LLAST=-1
30491       DO 1200 K=1,N
30492          L=NINT((X(K)-XMIN)/XZOOM)
30493          I=NINT((YMAX-Y1(K))/YZOOM)
30494          IF(ILAST.GE.0) THEN
30495            LD = L-LLAST
30496            ID = I-ILAST
30497            DO 55 II=0,LD,SIGN(1,LD)
30498              DO 66 KK=0,ID,SIGN(1,ID)
30499                COL(II+LLAST,KK+ILAST)=SYMB(1)
30500  66          CONTINUE
30501  55        CONTINUE
30502          ELSE
30503            COL(L,I)=SYMB(1)
30504          ENDIF
30505          ILAST = I
30506          LLAST = L
30507 1200  CONTINUE
30508 C
30509       IF(IARG.GT.1) THEN
30510 C
30511 C***  plot curve Y2
30512 C
30513         DO 1250 K=1,N
30514            L=NINT((X(K)-XMIN)/XZOOM)
30515            I=NINT((YMAX-Y2(K))/YZOOM)
30516            COL(L,I)=SYMB(2)
30517 1250    CONTINUE
30518       ENDIF
30519 C
30520 C***  write it
30521 C
30522       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30523 C
30524 C***  write range of X
30525 C
30526       XZOOM = (XMAX-XMIN)/DBLE(7)
30527       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30528 C
30529       DO 1300 K=0,IZEIL-1
30530          YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30531          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30532  110     FORMAT(1X,1PE9.2,70A1)
30533 1300  CONTINUE
30534 C
30535 C***  write range of X
30536 C
30537       XZOOM = (XMAX-XMIN)/DBLE(7)
30538       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30539       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30540  120  FORMAT(6X,7(1PE10.3))
30541       END
30542
30543 *$ CREATE DT_XGLOGY.FOR
30544 *COPY DT_XGLOGY
30545 *
30546 *===qglogy=============================================================*
30547 *
30548       SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30549 C***********************************************************************
30550 C
30551 C     calculate quasi graphic picture with 25 lines and 79 columns
30552 C     logarithmic y axis
30553 C     ranges will be chosen automatically
30554 C
30555 C     input     N          dimension of input fields
30556 C               IARG       number of curves (fields) to plot
30557 C               X          field of X
30558 C               Y1         field of Y1
30559 C               Y2         field of Y2
30560 C
30561 C This subroutine is written by R. Engel.
30562 C***********************************************************************
30563 C
30564       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30565       SAVE
30566
30567       PARAMETER ( LINP = 10 ,
30568      &            LOUT = 6 ,
30569      &            LDAT = 9 )
30570
30571       DIMENSION X(N),Y1(N),Y2(N)
30572       PARAMETER (EPS=1.D-30)
30573       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30574       CHARACTER SYMB(5)
30575       CHARACTER COL(0:149,0:49)
30576       PARAMETER (DEPS = 1.D-10)
30577 C
30578       DATA SYMB /'0','e','z','#','x'/
30579 C
30580       ISPALT=IBREIT-10
30581 C
30582 C***  automatic range fitting
30583 C
30584       XMAX=X(1)
30585       XMIN=X(1)
30586       DO 600 I=1,N
30587          XMAX=MAX(X(I),XMAX)
30588          XMIN=MIN(X(I),XMIN)
30589  600  CONTINUE
30590       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30591 C
30592       ITEST=0
30593       DO 1100 K=0,IZEIL-1
30594          ITEST=ITEST+1
30595          IF (ITEST.EQ.IYRAST) THEN
30596             DO 1010 L=1,ISPALT-1
30597                COL(L,K)='-'
30598 1010        CONTINUE
30599             COL(ISPALT,K)='+'
30600             ITEST=0
30601             DO 1020 L=0,ISPALT-1,IXRAST
30602                COL(L,K)='+'
30603 1020        CONTINUE
30604          ELSE
30605             DO 1030 L=1,ISPALT-1
30606                COL(L,K)=' '
30607 1030        CONTINUE
30608             DO 1040 L=0,ISPALT-1,IXRAST
30609                COL(L,K)='|'
30610 1040        CONTINUE
30611             COL(ISPALT,K)='|'
30612          ENDIF
30613 1100  CONTINUE
30614 C
30615 C***  plot curve Y1
30616 C
30617       YMAX=Y1(1)
30618       YMIN=MAX(Y1(1),EPS)
30619       DO 500 I=1,N
30620          YMAX =MAX(Y1(I),YMAX)
30621          IF(Y1(I).GT.EPS) THEN
30622            IF(YMIN.EQ.EPS) THEN
30623              YMIN = Y1(I)/10.D0
30624            ELSE
30625              YMIN = MIN(Y1(I),YMIN)
30626            ENDIF
30627          ENDIF
30628 500   CONTINUE
30629       IF(IARG.GT.1) THEN
30630         DO 550 I=1,N
30631            YMAX=MAX(Y2(I),YMAX)
30632            IF(Y2(I).GT.EPS) THEN
30633              IF(YMIN.EQ.EPS) THEN
30634                YMIN = Y2(I)
30635              ELSE
30636                YMIN = MIN(Y2(I),YMIN)
30637              ENDIF
30638            ENDIF
30639 550     CONTINUE
30640       ENDIF
30641 C
30642       DO 560 I=1,N
30643         Y1(I) = MAX(Y1(I),YMIN)
30644  560  CONTINUE
30645       IF(IARG.GT.1) THEN
30646         DO 570 I=1,N
30647           Y2(I) = MAX(Y2(I),YMIN)
30648  570    CONTINUE
30649       ENDIF
30650 C
30651       IF(YMAX.LE.YMIN) THEN
30652         WRITE(LOUT,'(/1X,A,2E12.3,/)')
30653      &     'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30654         WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30655         RETURN
30656       ENDIF
30657 C
30658       YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30659       YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30660       YZOOM=(YMA-YMI)/DBLE(IZEIL)
30661       IF(YZOOM.LT.EPS) THEN
30662         WRITE(LOUT,'(1X,A)')
30663      &    'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30664         RETURN
30665       ENDIF
30666 C
30667 C***  plot curve Y1
30668 C
30669       ILAST=-1
30670       LLAST=-1
30671       DO 1200 K=1,N
30672          L=NINT((X(K)-XMIN)/XZOOM)
30673          I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30674          IF(ILAST.GE.0) THEN
30675            LD = L-LLAST
30676            ID = I-ILAST
30677            DO 55 II=0,LD,SIGN(1,LD)
30678              DO 66 KK=0,ID,SIGN(1,ID)
30679                COL(II+LLAST,KK+ILAST)=SYMB(1)
30680  66          CONTINUE
30681  55        CONTINUE
30682          ELSE
30683            COL(L,I)=SYMB(1)
30684          ENDIF
30685          ILAST = I
30686          LLAST = L
30687 1200  CONTINUE
30688 C
30689       IF(IARG.GT.1) THEN
30690 C
30691 C***  plot curve Y2
30692 C
30693         DO 1250 K=1,N
30694            L=NINT((X(K)-XMIN)/XZOOM)
30695            I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30696            COL(L,I)=SYMB(2)
30697 1250    CONTINUE
30698       ENDIF
30699 C
30700 C***  write it
30701 C
30702       WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30703       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30704 C
30705 C***  write range of X
30706 C
30707       XZOOM1 = (XMAX-XMIN)/DBLE(7)
30708       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30709 C
30710       DO 1300 K=0,IZEIL-1
30711          YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30712          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30713  110     FORMAT(1X,1PE9.2,70A1)
30714 1300  CONTINUE
30715 C
30716 C***  write range of X
30717 C
30718       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30719       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30720  120  FORMAT(6X,7(1PE10.3))
30721 C
30722       END
30723
30724 *$ CREATE DT_SRPLOT.FOR
30725 *COPY DT_SRPLOT
30726 *
30727 *===plot===============================================================*
30728 *
30729       SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30730
30731       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30732       SAVE
30733
30734       PARAMETER ( LINP = 10 ,
30735      &            LOUT = 6 ,
30736      &            LDAT = 9 )
30737
30738 *
30739 *     initial version
30740 *     J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30741 *     This is a subroutine of fluka to plot Y across the page
30742 *     as a function of X down the page. Up to 37 curves can be
30743 *     plotted in the same picture with different plotting characters.
30744 *     Output of first 10 overprinted characters addad by FB 88
30745 *  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30746 *
30747 *     Input Variables:
30748 *        X   = array containing the values of X
30749 *        Y   = array containing the values of Y
30750 *        N   = number of values in X and in Y
30751 *              can exceed the fixed number of lines
30752 *        M   = number of different curves X,Y are containing
30753 *        MM  = number of points in each curve i.e. N=M*MM
30754 *        XO  = smallest value of X to be plotted
30755 *        DX  = increment of X between subsequent lines
30756 *        YO  = smallest value of Y to be plotted
30757 *        DY  = increment of Y between subsequent character spaces
30758 *
30759 *        other variables used inside:
30760 *        XX  = numbers along the X-coordinate axis
30761 *        YY  = numbers along the Y-coordinate axis
30762 *        LL  = ten lines temporary storage for the plot
30763 *        L   = character set used to plot different curves
30764 *        LOV = memorizes overprinted symbols
30765 *              the first 10 overprinted symbols are printed on
30766 *              the end of the line to avoid ambiguities
30767 *              (added by FB as considered quite helpful)
30768 *
30769 *********************************************************************
30770 *
30771       DIMENSION XX(61),YY(61),LL(101,10)
30772       DIMENSION X(N),Y(N),L(40),LOV(40,10)
30773       INTEGER*4 LL, L, LOV
30774       DATA  L/
30775      11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30776      21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30777      31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30778      41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H  /
30779 *
30780 *
30781       MN=51
30782       DO 10 I=1,MN
30783         AI=I-1
30784    10 XX(I)=XO+AI*DX
30785       DO 20 I=1,11
30786         AI=I-1
30787    20 YY(I)=YO+10.0D0*AI*DY
30788       WRITE(LOUT, 500) (YY(I),I=1,11)
30789       MMN=MN-1
30790 *
30791 *
30792       DO 90 JJ=1,MMN,10
30793         JJJ=JJ-1
30794         DO 30 I=1,101
30795           DO 30 J=1,10
30796    30   LL(I,J)=L(40)
30797         DO 40 I=1,101
30798    40   LL(I,1)=L(39)
30799         DO 50 I=1,101,10
30800           DO 50 J=1,10
30801    50   LL(I,J)=L(38)
30802         DO 60 I=1,40
30803           DO 60 J=1,10
30804    60   LOV(I,J)=L(40)
30805 *
30806 *
30807         DO 70 I=1,M
30808           DO 70 J=1,MM
30809             II=J+(I-1)*MM
30810             AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30811             AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30812             AIX=AIX-DBLE(JJJ)
30813 *           changed Sept.88 by FB to avoid INTEGER OVERFLOW
30814             IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30815      +      . AIY .LT. 102.D0) THEN
30816               IX=INT(AIX)
30817               IY=INT(AIY)
30818               IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30819      +        THEN
30820                 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30821      +          =LL(IY,IX)
30822                 LL(IY,IX)=L(I)
30823               ENDIF
30824             ENDIF
30825    70   CONTINUE
30826 *
30827 *
30828         DO 80 I=1,10
30829           II=I+JJJ
30830           III=II+1
30831           WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30832      &                    (LOV(J,I),J=1,10)
30833    80   CONTINUE
30834    90 CONTINUE
30835 *
30836 *
30837       WRITE(LOUT, 520)
30838       WRITE(LOUT, 500) (YY(I),I=1,11)
30839       RETURN
30840 *
30841   500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30842   510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30843   520 FORMAT(20X,10('1---------'),'1')
30844       END
30845 *$ CREATE DT_DEFSET.FOR
30846 *COPY DT_DEFSET
30847 *
30848 *===defset=============================================================*
30849 *
30850       BLOCK DATA DT_DEFSET
30851
30852       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30853       SAVE
30854
30855 * flags for input different options
30856       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30857       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30858      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30859
30860       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30861
30862 * emulsion treatment
30863       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30864      &                NCOMPO,IEMUL
30865
30866 * / DTFLG1 /
30867       DATA IFRAG  / 2, 1 /
30868       DATA IRESCO / 1 /
30869       DATA IMSHL  / 1 /
30870       DATA IRESRJ / 0 /
30871       DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30872       DATA LEMCCK / .FALSE. /
30873       DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30874      &              .TRUE.,.TRUE.,.TRUE./
30875       DATA LSEADI / .TRUE. /
30876       DATA LEVAPO / .TRUE. /
30877       DATA IFRAME / 1 /
30878       DATA ITRSPT / 0 /
30879
30880 * / DTCOMP /
30881       DATA EMUFRA / NCOMPX*0.0D0 /
30882       DATA IEMUMA / NCOMPX*1 /
30883       DATA IEMUCH / NCOMPX*1 /
30884       DATA NCOMPO / 0 /
30885       DATA IEMUL  / 0 /
30886
30887       END
30888
30889 *$ CREATE DT_HADPRP.FOR
30890 *COPY DT_HADPRP
30891 *
30892 *===hadprp=============================================================*
30893 *
30894       BLOCK DATA DT_HADPRP
30895
30896       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30897       SAVE
30898
30899 * auxiliary common for reggeon exchange (DTUNUC 1.x)
30900       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30901      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30902      &                IQTCHR(-6:6),MQUARK(3,39)
30903
30904 * hadron index conversion (BAMJET <--> PDG)
30905       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30906      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30907      &                IAMCIN(210)
30908
30909 * names of hadrons used in input-cards
30910       CHARACTER*8 BTYPE
30911       COMMON /DTPAIN/ BTYPE(30)
30912
30913 * / DTQUAR /
30914 *----------------------------------------------------------------------*
30915 *                                                                      *
30916 *     Quark content of particles:                                      *
30917 *          index   quark   el. charge  bar. charge  isospin  isospin3  *
30918 *              1 = u          2/3          1/3        1/2       1/2    *
30919 *             -1 = ubar      -2/3         -1/3        1/2      -1/2    *
30920 *              2 = d         -1/3          1/3        1/2      -1/2    *
30921 *             -2 = dbar       1/3         -1/3        1/2       1/2    *
30922 *              3 = s         -1/3          1/3         0         0     *
30923 *             -3 = sbar       1/3         -1/3         0         0     *
30924 *              4 = c          2/3          1/3         0         0     *
30925 *             -4 = cbar      -2/3         -1/3         0         0     *
30926 *              5 = b         -1/3          1/3         0         0     *
30927 *             -5 = bbar       1/3         -1/3         0         0     *
30928 *              6 = t          2/3          1/3         0         0     *
30929 *             -6 = tbar      -2/3         -1/3         0         0     *
30930 *                                                                      *
30931 *         Mquark = particle quark composition (Paprop numbering)       *
30932 *         Iqechr = electric charge ( in 1/3 unit )                     *
30933 *         Iqbchr = baryonic charge ( in 1/3 unit )                     *
30934 *         Iqichr = isospin ( in 1/2 unit ), z component                *
30935 *         Iqschr = strangeness                                         *
30936 *         Iqcchr = charm                                               *
30937 *         Iquchr = beauty                                              *
30938 *         Iqtchr = ......                                              *
30939 *                                                                      *
30940 *----------------------------------------------------------------------*
30941       DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
30942       DATA IQBCHR / 6*-1, 0, 6*1 /
30943       DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
30944       DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
30945       DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
30946       DATA IQUCHR / 0, 1, 9*0, -1, 0 /
30947       DATA IQTCHR / -1, 11*0, 1 /
30948       DATA MQUARK /
30949      &   2, 1, 1,   -2,-1,-1,    0, 0, 0,    0, 0, 0,    0, 0, 0,
30950      &   0, 0, 0,    0, 0, 0,    2, 2, 1,   -2,-2,-1,    0, 0, 0,
30951      &   0, 0, 0,    0, 0, 0,    1,-2, 0,    2,-1, 0,    1,-3, 0,
30952      &   3,-1, 0,    1, 2, 3,   -1,-2,-3,    0, 0, 0,    2, 2, 3,
30953      &   1, 1, 3,    1, 2, 3,    1,-1, 0,    2,-3, 0,    3,-2, 0,
30954      &   2,-2, 0,    3,-3, 0,    0, 0, 0,    0, 0, 0,    0, 0, 0,
30955      &  -1,-1,-3,   -1,-2,-3,   -2,-2,-3,    1, 3, 3,   -1,-3,-3,
30956      &   2, 3, 3,   -2,-3,-3,    3, 3, 3,   -3,-3,-3 /
30957
30958 * / DTHAIC /
30959 * (renamed) (HAdron InDex COnversion)
30960 * translation table version filled up by r.e. 25.01.94                 *
30961       DATA IAMCIN /
30962      &2212,-2212,11,-11,12,              -12,22,2112,-2112,-13,
30963      &13,130,211,-211,321,               -321,3122,-3122,310,3112,
30964      &3222,3212,111,311,-311,            0,0,0,0,0,
30965      &221,213,113,-213,223,              323,313,-323,-313,10323,
30966      &10313,-10323,-10313,30323,30313,   -30323,-30313,3224,3214,3114,
30967      &3216,3218,2224,2214,2114,          1114,12224,12214,12114,11114,
30968      &99999,99999,22212,22112,32124,     31214,-2224,-2214,-2114,-1114,
30969      &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
30970      &5*99999,                           5*99999,
30971      &4*99999,331,                       333,3322,3312,-3222,-3212,
30972      &-3112,-3322,-3312,3224,3214,       3114,3324,3314,3334,-3224,
30973      &-3214,-3114,-3324,-3314,-3334,     421,411,-411,-421,431,
30974      &-431,441,423,413,-413,             -423,433,-433,20443,443,
30975      &-15,15,16,-16,14,                  -14,4122,4232,4132,4222,
30976      &4212,4112,3*99999,                 3*99999,-4122,-4232,
30977      &-4132,-4222,-4212,-4112,99999,     5*99999,
30978      &5*99999,                           5*99999,
30979      &10*99999,
30980      &5*99999 , 20211,20111,-20211,99999,20321,
30981      &-20321,20311,-20311,7*99999 ,
30982      &7*99999,12212,12112,99999/
30983
30984 * / DTHAIC /
30985 * (HAdron InDex COnversion)
30986       DATA (IPDG2(1,K),K=1,7)
30987      &   /   -11,   -12,   -13,   -15,   -16,   -14,     0/
30988       DATA (IBAM2(1,K),K=1,7)
30989      &   /     4,     6,    10,   131,   134,   136,     0/
30990       DATA (IPDG2(2,K),K=1,7)
30991      &   /    11,    12,    22,    13,    15,    16,    14/
30992       DATA (IBAM2(2,K),K=1,7)
30993      &   /     3,     5,     7,    11,   132,   133,   135/
30994       DATA (IPDG3(1,K),K=1,22)
30995      &   /  -211,  -321,  -311,  -213,  -323,  -313,  -411,  -421,
30996      &      -431,  -413,  -423,  -433,     0,     0,     0,     0,
30997      &         0,     0,     0,     0,     0,     0/
30998       DATA (IBAM3(1,K),K=1,22)
30999      &   /    14,    16,    25,    34,    38,    39,   118,   119,
31000      &       121,   125,   126,   128,     0,     0,     0,     0,
31001      &         0,     0,     0,     0,     0,     0/
31002       DATA (IPDG3(2,K),K=1,22)
31003      &   /   130,   211,   321,   310,   111,   311,   221,   213,
31004      &       113,   223,   323,   313,   331,   333,   421,   411,
31005      &       431,   441,   423,   413,   433,   443/
31006       DATA (IBAM3(2,K),K=1,22)
31007      &   /    12,    13,    15,    19,    23,    24,    31,    32,
31008      &        33,    35,    36,    37,    95,    96,   116,   117,
31009      &       120,   122,   123,   124,   127,   130/
31010       DATA (IPDG4(1,K),K=1,29)
31011      &   / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31012      &     -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31013      &     -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31014      &     -4212, -4112,     0,     0,     0/
31015       DATA (IBAM4(1,K),K=1,29)
31016      &   /     2,     9,    18,    67,    68,    69,    70,    75,
31017      &        76,    99,   100,   101,   102,   103,   110,   111,
31018      &       112,   113,   114,   115,   149,   150,   151,   152,
31019      &       153,   154,     0,     0,     0/
31020       DATA (IPDG4(2,K),K=1,29)
31021      &   /  2212,  2112,  3122,  3112,  3222,  3212,  3224,  3214,
31022      &      3114,  3216,  3218,  2224,  2214,  2114,  1114,  3322,
31023      &      3312,  3224,  3214,  3114,  3324,  3314,  3334,  4122,
31024      &      4232,  4132,  4222,  4212,  4112/
31025       DATA (IBAM4(2,K),K=1,29)
31026      &   /     1,     8,    17,    20,    21,    22,    48,    49,
31027      &        50,    51,    52,    53,    54,    55,    56,    97,
31028      &        98,   104,   105,   106,   107,   108,   109,   137,
31029      &       138,   139,   140,   141,   142/
31030       DATA (IPDG5(1,K),K=1,19)
31031      &   /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31032      &    -20211,-20321,-20311,     0,     0,     0,     0,     0,
31033      &         0,     0,     0/
31034       DATA (IBAM5(1,K),K=1,19)
31035      &   /    42,    43,    46,    47,    71,    72,    73,    74,
31036      &       188,   191,   193,     0,     0,     0,     0,     0,
31037      &         0,     0,     0/
31038       DATA (IPDG5(2,K),K=1,19)
31039      &   / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31040      &     22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31041      &     20311, 12212, 12112/
31042       DATA (IBAM5(2,K),K=1,19)
31043      &   /    40,    41,    44,    45,    57,    58,    59,    60,
31044      &        63,    64,    65,    66,   129,   186,   187,   190,
31045      &       192,   208,   209/
31046
31047 * / DTPAIN /
31048 * internal particle names
31049       DATA BTYPE / 'PROTON  ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31050      &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON  ' , 'NEUTRON ' , 'ANEUTRON' ,
31051      &'MUON+   ' , 'MUON-   ' , 'KAONLONG' , 'PION+   ' , 'PION-   ' ,
31052      &'KAON+   ' , 'KAON-   ' , 'LAMBDA  ' , 'ALAMBDA ' , 'KAONSHRT' ,
31053      &'SIGMA-  ' , 'SIGMA+  ' , 'SIGMAZER' , 'PIZERO  ' , 'KAONZERO' ,
31054      &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31055      &'BLANK   ' /
31056
31057       END
31058
31059 *$ CREATE DT_BLKD46.FOR
31060 *COPY DT_BLKD46
31061 *
31062 *===blkd46=============================================================*
31063 *
31064       BLOCK DATA DT_BLKD46
31065
31066       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31067       SAVE
31068
31069       PARAMETER ( AMELCT = 0.51099906         D-03 )
31070       PARAMETER ( AMMUON = 0.105658389        D+00 )
31071
31072 * particle properties (BAMJET index convention)
31073       CHARACTER*8  ANAME
31074       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31075      &                IICH(210),IIBAR(210),K1(210),K2(210)
31076
31077 * / DTPART /
31078 * Particle  masses Engel version JETSET compatible
31079 C     DATA (AAM(K),K=1,85) /
31080 C    &   .9383D+00, .9383D+00,  AMELCT  ,  AMELCT  , .0000D+00,
31081 C    &   .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON   ,
31082 C    &   AMMUON   , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31083 C    &   .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31084 C    &   .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31085 C    &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31086 C    &   .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31087 C    &   .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31088 C    &   .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31089 C    &   .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31090 C    &   .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31091 C    &   .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31092 C    &   .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31093 C    &   .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31094 C    &   .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31095 C    &   .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31096 C    &   .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01  /
31097 C     DATA (AAM(K),K=86,183) /
31098 C    &   .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31099 C    &   .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31100 C    &   .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31101 C    &   .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31102 C    &   .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31103 C    &   .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31104 C    &   .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31105 C    &   .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31106 C    &   .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31107 C    &   .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31108 C    &   .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31109 C    &   .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31110 C    &   .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31111 C    &   .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31112 C    &   .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31113 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31114 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31115 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31116 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31117 C    &   .1250D+01, .1250D+01, .1250D+01  /
31118 C     DATA (AAM ( I ), I = 184,210 ) /
31119 C    & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31120 C    & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31121 C    & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31122 C    & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31123 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31124 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31125 C    & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31126 C    & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31127 C    & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31128 * sr 25.1.06: particle masses adjusted to Pythia
31129       DATA (AAM(K),K=1,85) /
31130      &   .938270E+00,.938270E+00, AMELCT    , AMELCT    ,.000000E+00,
31131      &   .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON    ,
31132      &    AMMUON    ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31133      &   .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31134      &   .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31135      &     .0000D+00,  .0000D+00,  .0000D+00 , .0000D+00,  .0000D+00,
31136      &   .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31137      &   .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31138      &   .129000E+01,.129000E+01,.129000E+01,  .1421D+01,  .1421D+01,
31139      &     .1421D+01,  .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31140      &     .1820D+01,  .2030D+01,  .1231D+01,  .1232D+01,  .1233D+01,
31141      &     .1234D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,
31142      &     .1500D+01,  .1500D+01,  .1515D+01,  .1515D+01,  .1775D+01,
31143      &     .1775D+01,  .1231D+01,  .1232D+01,  .1233D+01,  .1234D+01,
31144      &     .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1515D+01,
31145      &     .1515D+01,  .2500D+01,  .4890D+00,  .4890D+00,  .4890D+00,
31146      &     .1300D+01,  .1300D+01,  .1300D+01,  .1300D+01,  .2200D+01  /
31147       DATA (AAM(K),K=86,183) /
31148      &     .2200D+01,  .2200D+01,  .2200D+01,  .1700D+01,  .1700D+01,
31149      &     .1700D+01,  .1700D+01,  .1820D+01,  .2030D+01,.957770E+00,
31150      &   .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31151      &   .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31152      &   .138720E+01,.153180E+01,  .1535D+01,.167245E+01,.138280E+01,
31153      &   .138370E+01,.138720E+01,.153180E+01,  .1535D+01,.167245E+01,
31154      &   .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31155      &   .196850E+01,.297980E+01,.200670E+01,  .2010D+01,  .2010D+01,
31156      &   .200670E+01,.211240E+01,.211240E+01,  .3686D+01,.309688E+01,
31157      &   .177700E+01,.177700E+01,  .0000D+00,  .0000D+00,  .0000D+00,
31158      &     .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31159      &   .245350E+01,.245210E+01,  .2560D+01,  .2560D+01,  .2730D+01,
31160      &     .3610D+01,  .3610D+01,  .3790D+01,.228490E+01,.246560E+01,
31161      &     .2460D+01,.245290E+01,.245350E+01,.245210E+01,  .2560D+01,
31162      &     .2560D+01,  .2730D+01,  .3610D+01,  .3610D+01,  .3790D+01,
31163      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31164      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31165      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31166      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31167      &     .1250D+01,  .1250D+01,  .1250D+01  /
31168       DATA (AAM ( I ), I = 184,210 ) /
31169      & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31170      & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31171      & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31172      & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31173      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31174      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31175      & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31176      & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31177      & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31178 * Particle  mean lives
31179       DATA (TAU(K),K=1,183) /
31180      &   .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31181      &   .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31182      &   .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31183      &   .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31184      &   .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31185      &   70*.0000D+00,
31186      &   .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31187      &   .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31188      &   .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31189      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31190      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31191      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31192      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31193      &   .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31194      &   .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31195      &   40*.0000D+00,
31196      &   .0000D+00, .0000D+00, .0000D+00  /
31197       DATA ( TAU ( I ), I = 184,210 ) /
31198      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31199      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31200      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31201      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31202      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31203      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31204      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31205      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31206      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31207 * Resonance width Gamma in GeV
31208       DATA (GA(K),K=  1,85) /
31209      &    30*.0000D+00,
31210      &   .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31211      &   .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31212      &   .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31213      &   .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31214      &   .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31215      &   .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31216      &   .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31217      &   .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31218      &   .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31219      &   .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31220      &   .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00  /
31221       DATA (GA(K),K= 86,183) /
31222      &   .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31223      &   .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31224      &   .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31225      &   .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31226      &   .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31227      &   .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31228      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31229      &   .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31230      &   .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31231      &   50*.0000D+00,
31232      &   .3000D+00, .3000D+00, .3000D+00  /
31233       DATA ( GA ( I ), I = 184,210 ) /
31234      & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31235      & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31236      & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31237      & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31238      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31239      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31240      & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31241      & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31242      & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31243 * Particle  names
31244 * S+1385+Sigma+(1385)    L02030+Lambda0(2030)
31245 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31246 * designation N*@@ means N*@1(@2)
31247       DATA (ANAME(K),K=1,85) /
31248      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31249      &  'ANUE    ','GAM     ','NEU     ','ANEU    ','MUE+    ',
31250      &  'MUE-    ','K0L     ','PI+     ','PI-     ','K+      ',
31251      &  'K-      ','LAM     ','ALAM    ','K0S     ','SIGM-   ',
31252      &  'SIGM+   ','SIGM0   ','PI0     ','K0      ','AK0     ',
31253      &  'BLANK   ','BLANK   ','BLANK   ','BLANK   ','BLANK   ',
31254      &  'ETA550  ','RHO+77  ','RHO077  ','RHO-77  ','OM0783  ',
31255      &  'K*+892  ','K*0892  ','K*-892  ','AK*089  ','KA+125  ',
31256      &  'KA0125  ','KA-125  ','AKA012  ','K*+142  ','K*0142  ',
31257      &  'K*-142  ','AK*014  ','S+1385  ','S01385  ','S-1385  ',
31258      &  'L01820  ','L02030  ','N*++12  ','N*+ 12  ','N*012   ',
31259      &  'N*-12   ','N*++16  ','N*+16   ','N*016   ','N*-16   ',
31260      &  'N*+14   ','N*014   ','N*+15   ','N*015   ','N*+18   ',
31261      &  'N*018   ','AN--12  ','AN*-12  ','AN*012  ','AN*+12  ',
31262      &  'AN--16  ','AN*-16  ','AN*016  ','AN*+16  ','AN*-15  ',
31263      &  'AN*015  ','DE*=24  ','RPI+49  ','RPI049  ','RPI-49  ',
31264      &  'PIN++   ','PIN+0   ','PIN+-   ','PIN-0   ','PPPI    ' /
31265       DATA (ANAME(K),K=86,183) /
31266      &  'PNPI    ','APPPI   ','APNPI   ','K+PPI   ','K-PPI   ',
31267      &  'K+NPI   ','K-NPI   ','S+1820  ','S-2030  ','ETA*    ',
31268      &  'PHI     ','TETA0   ','TETA-   ','ASIG-   ','ASIG0   ',
31269      &  'ASIG+   ','ATETA0  ','ATETA+  ','SIG*+   ','SIG*0   ',
31270      &  'SIG*-   ','TETA*0  ','TETA*   ','OMEGA-  ','ASIG*-  ',
31271      &  'ASIG*0  ','ASIG*+  ','ATET*0  ','ATET*+  ','OMEGA+  ',
31272      &  'D0      ','D+      ','D-      ','AD0     ','F+      ',
31273      &  'F-      ','ETAC    ','D*0     ','D*+     ','D*-     ',
31274      &  'AD*0    ','F*+     ','F*-     ','PSI     ','JPSI    ',
31275      &  'TAU+    ','TAU-    ','NUET    ','ANUET   ','NUEM    ',
31276      &  'ANUEM   ','C0+     ','A+      ','A0      ','C1++    ',
31277      &  'C1+     ','C10     ','S+      ','S0      ','T0      ',
31278      &  'XU++    ','XD+     ','XS+     ','AC0-    ','AA-     ',
31279      &  'AA0     ','AC1--   ','AC1-    ','AC10    ','AS-     ',
31280      &  'AS0     ','AT0     ','AXU--   ','AXD-    ','AXS     ',
31281      &  'C1*++   ','C1*+    ','C1*0    ','S*+     ','S*0     ',
31282      &  'T*0     ','XU*++   ','XD*+    ','XS*+    ','TETA++  ',
31283      &  'AC1*--  ','AC1*-   ','AC1*0   ','AS*-    ','AS*0    ',
31284      &  'AT*0    ','AXU*--  ','AXD*-   ','AXS*-   ','ATET--  ',
31285      &  'RO      ','R+      ','R-      '  /
31286       DATA (    ANAME ( I ), I = 184,210 ) /
31287      &'AN*-14  ','AN*014  ','PI+130  ','PI0130  ','PI-130  ','F01400  ',
31288      &'K*+146  ','K*-146  ','K*0146  ','AK0146  ','L01600  ','AL0160  ',
31289      &'S+1660  ','S01660  ','S-1660  ','AS-166  ','AS0166  ','AS+166  ',
31290      &'X01950  ','X-1950  ','AX0195  ','AX+195  ','OM-225  ','AOM+22  ',
31291      &'N*+14   ','N*014   ','BLANK   '/
31292 * Charge of particles and resonances
31293       DATA (IICH ( I ), I =   1,210 ) /
31294      &  1, -1, -1,  1,  0,  0,  0,  0,  0,  1, -1,  0,  1, -1,  1,
31295      & -1,  0,  0,  0, -1,  1,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31296      &  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0,
31297      & -1,  0,  1,  0, -1,  0,  0,  2,  1,  0, -1,  2,  1,  0, -1,
31298      &  1,  0,  1,  0,  1,  0, -2, -1,  0,  1, -2, -1,  0,  1, -1,
31299      &  0,  1,  1,  0, -1,  2,  1,  0, -1,  2,  1,  0, -1,  2,  0,
31300      &  1, -1,  1, -1,  0,  0,  0, -1, -1,  0,  1,  0,  1,  1,  0,
31301      & -1,  0, -1, -1, -1,  0,  1,  0,  1,  1,  0,  1, -1,  0,  1,
31302      & -1,  0,  0,  1, -1,  0,  1, -1,  0,  0,  1, -1,  0,  0,  0,
31303      &  0,  1,  1,  0,  2,  1,  0,  1,  0,  0,  2,  1,  1, -1, -1,
31304      &  0, -2, -1,  0, -1,  0,  0, -2, -1, -1,  2,  1,  0,  1,  0,
31305      &  0,  2,  1,  1,  2, -2, -1,  0, -1,  0,  0, -2, -1, -1, -2,
31306      &  0,  1, -1, -1,  0,  1,  0, -1,  0,  1, -1,  0,  0,  0,  0,
31307      &  1,  0, -1, -1,  0,  1,  0, -1,  0,  1, -1,  1,  1,  0,  0/
31308 * Particle  baryonic charges
31309       DATA (IIBAR ( I ), I =   1,210 ) /
31310      &  1, -1,  0,  0,  0,  0,  0,  1, -1,  0,  0,  0,  0,  0,  0,
31311      &  0,  1, -1,  0,  1,  1,  1,  0,  0,  0,  0,  0,  0,  0,  0,
31312      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31313      &  0,  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
31314      &  1,  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31315      & -1,  2,  0,  0,  0,  1,  1,  1,  1,  2,  2,  0,  0,  1,  1,
31316      &  1,  1,  1,  1,  0,  0,  1,  1, -1, -1, -1, -1, -1,  1,  1,
31317      &  1,  1,  1,  1, -1, -1, -1, -1, -1, -1,  0,  0,  0,  0,  0,
31318      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31319      &  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1, -1, -1,
31320      & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,  1,  1,  1,  1,  1,
31321      &  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31322      &  0,  0,  0, -1, -1,  0,  0,  0,  0,  0,  0,  0,  0,  1, -1,
31323      &  1,  1,  1, -1, -1, -1,  1,  1, -1, -1,  1, -1,  1,  1,  0/
31324 * First number of decay channels used for resonances
31325 * and decaying particles
31326       DATA K1/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 16, 17,
31327      &  18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31328      &   2*330, 46, 51, 52, 54, 55, 58,
31329 *                                                             50
31330      &  60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31331      & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31332      & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31333 *                                         85
31334      & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31335      & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31336      & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31337      & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31338      & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31339      & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31340      & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31341      & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31342      & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31343      & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31344      & 590, 596, 602 /
31345 * Last number of decay channels used for resonances
31346 * and decaying particles
31347       DATA K2/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 15, 16, 17,
31348      & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31349      & 2* 330, 50, 51, 53, 54, 57,
31350 *                                                                 50
31351      & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31352      & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31353      & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31354 *                                              85
31355      & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31356      & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31357      & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31358      & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31359      & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31360      & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31361      & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31362      & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31363      & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31364      & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31365      & 589, 595, 601, 602 /
31366
31367        END
31368
31369 *$ CREATE DT_BLKD47.FOR
31370 *COPY DT_BLKD47
31371 *
31372 *===blkd47=============================================================*
31373 *
31374       BLOCK DATA DT_BLKD47
31375
31376       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31377       SAVE
31378
31379 * HADRIN: decay channel information
31380       PARAMETER (IDMAX9=602)
31381       CHARACTER*8 ZKNAME
31382       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31383
31384 * Name of decay channel
31385 * Designation N*@ means N*@1(1236)
31386 * @1=# means ++,  @1 = = means --
31387 * Designation  P+/0/- means Pi+/Pi0/Pi- , respectively
31388       DATA (ZKNAME(K),K=  1, 85) /
31389      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31390      &  'ANUE    ','GAM     ','PE-NUE  ','APEANU  ','EANUNU  ',
31391      &  'E-NUAN  ','3PI0    ','PI+-0   ','PIMUNU  ','PIE-NU  ',
31392      &  'MU+NUE  ','MU-NUE  ','MU+NUE  ','PI+PI0  ','PI++-   ',
31393      &  'PI+00   ','M+P0NU  ','E+P0NU  ','MU-NU   ','PI-0    ',
31394      &  'PI+--   ','PI-00   ','M-P0NU  ','E-P0NU  ','PPI-    ',
31395      &  'NPI0    ','PD-NUE  ','PM-NUE  ','APPI+   ','ANPI0   ',
31396      &  'APE+NU  ','APM+NU  ','PI+PI-  ','PI0PI0  ','NPI-    ',
31397      &  'PPI0    ','NPI+    ','LAGA    ','GAGA    ','GAE+E-  ',
31398      &  'GAGA    ','GAGAP0  ','PI000   ','PI+-0   ','PI+-GA  ',
31399      &  'PI+0    ','PI+-    ','PI00    ','PI-0    ','PI+-0   ',
31400      &  'PI+-    ','PI0GA   ','K+PI0   ','K0PI+   ','KOPI0   ',
31401      &  'K+PI-   ','K-PI0   ','AK0PI-  ','AK0PI0  ','K-PI+   ',
31402      &  'K+PI0   ','K0PI+   ','K0PI0   ','K+PI-   ','K-PI0   ',
31403      &  'K0PI-   ','AK0PI0  ','K-PI+   ','K+PI0   ','K0PI+   ',
31404      &  'K+89P0  ','K08PI+  ','K+RO77  ','K0RO+7  ','K+OM07  ',
31405      &  'K+E055  ','K0PI0   ','K+PI+   ','K089P0  ','K+8PI-  '  /
31406       DATA (ZKNAME(K),K= 86,170) /
31407      &  'K0R077  ','K+R-77  ','K+R-77  ','K0OM07  ','K0E055  ',
31408      &  'K-PI0   ','K0PI-   ','K-89P0  ','AK08P-  ','K-R077  ',
31409      &  'AK0R-7  ','K-OM07  ','K-E055  ','AK0PI0  ','K-PI+   ',
31410      &  'AK08P0  ','K-8PI+  ','AK0R07  ','AK0OM7  ','AK0E05  ',
31411      &  'LA0PI+  ','SI0PI+  ','SI+PI0  ','LA0PI0  ','SI+PI-  ',
31412      &  'SI-PI+  ','LA0PI-  ','SI0PI-  ','NEUAK0  ','PK-     ',
31413      &  'SI+PI-  ','SI0PI0  ','SI-PI+  ','LA0ET0  ','S+1PI-  ',
31414      &  'S-1PI+  ','SO1PI0  ','NEUAK0  ','PK-     ','LA0PI0  ',
31415      &  'LA0OM0  ','LA0RO0  ','SI+RO-  ','SI-RO+  ','SI0RO0  ',
31416      &  'LA0ET0  ','SI0ET0  ','SI+PI-  ','SI-PI+  ','SI0PI0  ',
31417      &  'K0S     ','K0L     ','K0S     ','K0L     ','P PI+   ',
31418      &  'P PI0   ','N PI+   ','P PI-   ','N PI0   ','N PI-   ',
31419      &  'P PI+   ','N*#PI0  ','N*+PI+  ','PRHO+   ','P PI0   ',
31420      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31421      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31422      &  'N*-PI+  ','PRHO-   ','NRHO0   ','N PI-   ','N*0PI-  ',
31423      &  'N*-PI0  ','NRHO-   ','PETA0   ','N*#PI-  ','N*+PI0  '  /
31424       DATA (ZKNAME(K),K=171,255) /
31425      &  'N*0PI+  ','PRHO0   ','NRHO+   ','NETA0   ','N*+PI-  ',
31426      &  'N*0PI0  ','N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ',
31427      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31428      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31429      &  'N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ','N PI+   ',
31430      &  'PRHO0   ','NRHO+   ','LAMK+   ','S+ K0   ','S0 K+   ',
31431      &  'PETA0   ','P PI-   ','N PI0   ','PRHO-   ','NRHO0   ',
31432      &  'LAMK0   ','S0 K0   ','S- K+   ','NETA/   ','APPI-   ',
31433      &  'APPI0   ','ANPI-   ','APPI+   ','ANPI0   ','ANPI+   ',
31434      &  'APPI-   ','AN*=P0  ','AN*-P-  ','APRHO-  ','APPI0   ',
31435      &  'ANPI-   ','AN*=P+  ','AN*-P0  ','AN*0P-  ','APRHO0  ',
31436      &  'ANRHO-  ','APPI+   ','ANPI0   ','AN*-P+  ','AN*0P0  ',
31437      &  'AN*+P-  ','APRHO+  ','ANRHO0  ','ANPI+   ','AN*0P+  ',
31438      &  'AN*+P0  ','ANRHO+  ','APPI0   ','ANPI-   ','AN*=P+  ',
31439      &  'AN*-P0  ','AN*0P-  ','APRHO0  ','ANRHO-  ','APPI+,  ',
31440      &  'ANPI0   ','AN*-P+  ','AN*0P0  ','AN*+P-  ','APRHO+  ',
31441      &  'ANRHO0  ','PN*014  ','NN*=14  ','PI+0    ','PI+-    '  /
31442       DATA (ZKNAME(K),K=256,340) /
31443      &  'PI-0    ','P+0     ','N++     ','P+-     ','P00     ',
31444      &  'N+0     ','N+-     ','N00     ','P-0     ','N-0     ',
31445      &  'P--     ','PPPI0   ','PNPI+   ','PNPI0   ','PPPI-   ',
31446      &  'NNPI+   ','APPPI0  ','APNPI+  ','ANNPI0  ','ANPPI-  ',
31447      &  'APNPI0  ','APPPI-  ','ANNPI-  ','K+PPI0  ','K+NPI+  ',
31448      &  'K0PPI0  ','K-PPI0  ','K-NPI+  ','AKPPI-  ','AKNPI0  ',
31449      &  'K+NPI0  ','K+PPI-  ','K0PPI0  ','K0NPI+  ','K-NPI0  ',
31450      &  'K-PPI-  ','AKNPI-  ','PAK0    ','SI+PI0  ','SI0PI+  ',
31451      &  'SI+ETA  ','S+1PI0  ','S01PI+  ','NEUK-   ','LA0PI-  ',
31452      &  'SI-OM0  ','LA0RO-  ','SI0RO-  ','SI-RO0  ','SI-ET0  ',
31453      &  'SI0PI-  ','SI-0    ','BLANC   ','BLANC   ','BLANC   ',
31454      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31455      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31456      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31457      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31458      &  'EPI+-   ','EPI00   ','GAPI+-  ','GAGA*   ','K+-     ',
31459      &  'KLKS    ','PI+-0   ','EGA     ','LPI0    ','LPI     '  /
31460       DATA (ZKNAME(K),K=341,425) /
31461      &  'APPI0   ','ANPI-   ','ALAGA   ','ANPI    ','ALPI0   ',
31462      &  'ALPI+   ','LAPI+   ','SI+PI0  ','SI0PI+  ','LAPI0   ',
31463      &  'SI+PI-  ','SI-PI+  ','LAPI-   ','SI-PI0  ','SI0PI-  ',
31464      &  'TE0PI0  ','TE-PI+  ','TE0PI-  ','TE-PI0  ','TE0PI   ',
31465      &  'TE-PI   ','LAK-    ','ALPI-   ','AS-PI0  ','AS0PI-  ',
31466      &  'ALPI0   ','AS+PI-  ','AS-PI+  ','ALPI+   ','AS+PI0  ',
31467      &  'AS0PI+  ','AT0PI0  ','AT+PI-  ','AT0PI+  ','AT+PI0  ',
31468      &  'AT0PI   ','AT+PI   ','ALK+    ','K-PI+   ','K-PI+0  ',
31469      &  'K0PI+-  ','K0PI0   ','K-PI++  ','AK0PI+  ','K+PI--  ',
31470      &  'K0PI-   ','K+PI-   ','K+PI-0  ','AKPI-+  ','AK0PI0  ',
31471      &  'ETAPIF  ','K++-    ','K+AK0   ','ETAPI-  ','K--+    ',
31472      &  'K-K0    ','PI00    ','PI+-    ','GAGA    ','D0PI0   ',
31473      &  'D0GA    ','D0PI+   ','D+PI0   ','DFGA    ','AD0PI-  ',
31474      &  'D-PI0   ','D-GA    ','AD0PI0  ','AD0GA   ','F+GA    ',
31475      &  'F+GA    ','F-GA    ','F-GA    ','PSPI+-  ','PSPI00  ',
31476      &  'PSETA   ','E+E-    ','MUE+-   ','PI+-0   ','M+NN    ',
31477      &  'E+NN    ','RHO+NT  ','PI+ANT  ','K*+ANT  ','M-NN    '  /
31478       DATA (ZKNAME(K),K=426,510) /
31479      &  'E-NN    ','RHO-NT  ','PI-NT   ','K*-NT   ','NUET    ',
31480      &  'ANUET   ','NUEM    ','ANUEM   ','SI+ETA  ','SI+ET*  ',
31481      &  'PAK0    ','TET0K+  ','SI*+ET  ','N*+AK0  ','N*++K-  ',
31482      &  'LAMRO+  ','SI0RO+  ','SI+RO0  ','SI+OME  ','PAK*0   ',
31483      &  'N*+AK*  ','N*++K*  ','SI+AK0  ','TET0PI  ','SI+AK*  ',
31484      &  'TET0RO  ','SI0AK*  ','SI+K*-  ','TET0OM  ','TET-RO  ',
31485      &  'SI*0AK  ','C0+PI+  ','C0+PI0  ','C0+PI-  ','A+GAM   ',
31486      &  'A0GAM   ','TET0AK  ','TET0K*  ','OM-RO+  ','OM-PI+  ',
31487      &  'C1++AK  ','A+PI+   ','C0+AK0  ','A0PI+   ','A+AK0   ',
31488      &  'T0PI+   ','ASI-ET  ','ASI-E*  ','APK0    ','ATET0K  ',
31489      &  'ASI*-E  ','AN*-K0  ','AN*--K  ','ALAMRO  ','ASI0RO  ',
31490      &  'ASI-RO  ','ASI-OM  ','APK*0   ','AN*-K*  ','AN*--K  ',
31491      &  'ASI-K0  ','ATETPI  ','ASI-K*  ','ATETRO  ','ASI0K*  ',
31492      &  'ASI-K*  ','ATE0OM  ','ATE+RO  ','ASI*0K  ','AC-PI-  ',
31493      &  'AC-PI0  ','AC-PI+  ','AA-GAM  ','AA0GAM  ','ATET0K  ',
31494      &  'ATE0K*  ','AOM+RO  ','AOM+PI  ','AC1--K  ','AA-PI-  ',
31495      &  'AC0-K0  ','AA0PI-  ','AA-K0   ','AT0PI-  ','C1++GA  '  /
31496       DATA (ZKNAME(K),K=511,540) /
31497      &  'C1++GA  ','C10GAM  ','S+GAM   ','S0GAM   ','T0GAM   ',
31498      &  'XU++GA  ','XD+GAM  ','XS+GAM  ','A+AKPI  ','T02PI+  ',
31499      &  'C1++2K  ','AC1--G  ','AC1-GA  ','AC10GA  ','AS-GAM  ',
31500      &  'AS0GAM  ','AT0GAM  ','AXU--G  ','AXD-GA  ','AXS-GA  ',
31501      &  'AA-KPI  ','AT02PI  ','AC1--K  ','RH-PI+  ','RH+PI-  ',
31502      &  'RH3PI0  ','RH0PI+  ','RH+PI0  ','RH0PI-  ','RH-PI0  '  /
31503       DATA (ZKNAME(I),I=541,602)/
31504      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31505      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31506      & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31507      & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31508      & 'PI+PI-','K+K-  ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31509      & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31510      & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31511      & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31512      & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31513 * Weight of decay channel
31514       DATA (WT(K),K=  1, 85) /
31515      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31516      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31517      &   .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31518      &   .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31519      &   .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31520      &   .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31521      &   .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31522      &   .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31523      &   .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31524      &   .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31525      &   .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31526      &   .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31527      &   .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31528      &   .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31529      &   .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31530      &   .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31531      &   .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00  /
31532       DATA (WT(K),K= 86,170) /
31533      &   .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31534      &   .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31535      &   .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31536      &   .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31537      &   .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31538      &   .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31539      &   .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31540      &   .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31541      &   .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31542      &   .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31543      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31544      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31545      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31546      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31547      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31548      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31549      &   .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00  /
31550       DATA (WT(K),K=171,255) /
31551      &   .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31552      &   .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31553      &   .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31554      &   .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31555      &   .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31556      &   .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31557      &   .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31558      &   .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31559      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31560      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31561      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31562      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31563      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31564      &   .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31565      &   .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31566      &   .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31567      &   .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01  /
31568       DATA (WT(K),K=256,340) /
31569      &   .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31570      &   .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31571      &   .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31572      &   .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31573      &   .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31574      &   .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31575      &   .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31576      &   .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31577      &   .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31578      &   .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31579      &   .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31580      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31581      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31582      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31583      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31584      &   .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31585      &   .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01  /
31586       DATA (WT(K),K=341,425) /
31587      &   .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31588      &   .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31589      &   .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31590      &   .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31591      &   .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31592      &   .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31593      &   .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31594      &   .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31595      &   .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31596      &   .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31597      &   .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31598      &   .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31599      &   .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31600      &   .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31601      &   .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31602      &   .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31603      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00  /
31604       DATA (WT(K),K=426,510) /
31605      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31606      &   .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31607      &   .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31608      &   .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31609      &   .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31610      &   .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31611      &   .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31612      &   .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31613      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31614      &   .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31615      &   .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31616      &   .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31617      &   .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31618      &   .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31619      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31620      &   .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31621      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01  /
31622       DATA (WT(K),K=511,540) /
31623      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31624      &   .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31625      &   .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31626      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31627      &   .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31628      &   .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00  /
31629 C
31630       DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31631      & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31632      & .125D+00,  0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31633      & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31634      & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31635      & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31636      & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31637 * Particle numbers in decay channel
31638       DATA (NZK(K,1),K=  1,170) /
31639      &     1,   2,   3,   4,   5,   6,   7,   1,   2,   4,
31640      &     3,  23,  13,  13,  13,  10,  11,  10,  13,  13,
31641      &    13,  10,   4,  11,  14,  14,  14,  11,   3,   1,
31642      &     8,   1,   1,   2,   9,   2,   2,  13,  23,   8,
31643      &     1,   8,  17,   7,   7,   7,  23,  23,  13,  13,
31644      &    13,  13,  23,  14,  13,  13,  23,  15,  24,  24,
31645      &    15,  16,  25,  25,  16,  15,  24,  24,  15,  16,
31646      &    24,  25,  16,  15,  24,  36,  37,  15,  24,  15,
31647      &    15,  24,  15,  37,  36,  24,  15,  24,  24,  16,
31648      &    24,  38,  39,  16,  25,  16,  16,  25,  16,  39,
31649      &    38,  25,  16,  25,  25,  17,  22,  21,  17,  21,
31650      &    20,  17,  22,   8,   1,  21,  22,  20,  17,  48,
31651      &    50,  49,   8,   1,  17,  17,  17,  21,  20,  22,
31652      &    17,  22,  21,  20,  22,  19,  12,  19,  12,   1,
31653      &     1,   8,   1,   8,   8,   1,  53,  54,   1,   1,
31654      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31655      &    56,   1,   8,   8,  55,  56,   8,   1,  53,  54  /
31656       DATA (NZK(K,1),K=171,340) /
31657      &    55,   1,   8,   8,  54,  55,  56,   1,   8,   1,
31658      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31659      &    56,   1,   8,   1,   8,   1,   8,  17,  21,  22,
31660      &     1,   1,   8,   1,   8,  17,  22,  20,   8,   2,
31661      &     2,   9,   2,   9,   9,   2,  67,  68,   2,   2,
31662      &     9,  67,  68,  69,   2,   9,   2,   9,  68,  69,
31663      &    70,   2,   9,   9,  69,  70,   9,   2,   9,  67,
31664      &    68,  69,   2,   9,   2,   9,  68,  69,  70,   2,
31665      &     9,   1,   8,  13,  13,  14,   1,   8,   1,   1,
31666      &     8,   8,   8,   1,   8,   1,   1,   1,   1,   1,
31667      &     8,   2,   2,   9,   9,   2,   2,   9,  15,  15,
31668      &    24,  16,  16,  25,  25,  15,  15,  24,  24,  16,
31669      &    16,  25,   1,  21,  22,  21,  48,  49,   8,  17,
31670      &    20,  17,  22,  20,  20,  22,  20,   0,   0,   0,
31671      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31672      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31673      &    31,  31,  13,   7,  15,  12,  13,  31,  17,  17  /
31674       DATA (NZK(K,1),K=341,510) /
31675      &     2,   9,  18,   9,  18,  18,  17,  21,  22,  17,
31676      &    21,  20,  17,  20,  22,  97,  98,  97,  98,  97,
31677      &    98,  17,  18,  99, 100,  18, 101,  99,  18, 101,
31678      &   100, 102, 103, 102, 103, 102, 103,  18,  16,  16,
31679      &    24,  24,  16,  25,  15,  24,  15,  15,  25,  25,
31680      &    31,  15,  15,  31,  16,  16,  23,  13,   7, 116,
31681      &   116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31682      &   120, 121, 121, 130, 130, 130,   4,  10,  13,  10,
31683      &     4,  32,  13,  36,  11,   3,  34,  14,  38, 133,
31684      &   134, 135, 136,  21,  21,   1,  97, 104,  54,  53,
31685      &    17,  22,  21,  21,   1,  54,  53,  21,  97,  21,
31686      &    97,  22,  21,  97,  98, 105, 137, 137, 137, 138,
31687      &   139,  97,  97, 109, 109, 140, 138, 137, 139, 138,
31688      &   145,  99,  99,   2, 102, 110,  68,  67,  18, 100,
31689      &    99,  99,   2,  68,  67,  99, 102,  99, 102, 100,
31690      &    99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31691      &   113, 115, 115, 152, 150, 149, 151, 150, 157, 140  /
31692       DATA (NZK(K,1),K=511,540) /
31693      &   141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31694      &   140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31695      &   150, 157, 152,  34,  32,  33,  33,  32,  33,  34  /
31696       DATA (NZK(I,1),I=541,602) /  2, 67, 68, 69,  2,  9,  9, 68, 69,
31697      & 70,  2,  9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31698      & 14, 189, 23, 13, 15, 24,  36,  38,  37,  39, 194, 195, 196, 197,
31699      & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31700      & 55, 8, 1, 8, 8, 54, 55, 210/
31701       DATA (NZK(K,2),K=  1,170) /
31702      &     0,   0,   0,   0,   0,   0,   0,   3,   4,   6,
31703      &     5,  23,  14,  11,   3,   5,   5,   5,  23,  13,
31704      &    23,  23,  23,   5,  23,  13,  23,  23,  23,  14,
31705      &    23,   3,  11,  13,  23,   4,  10,  14,  23,  14,
31706      &    23,  13,   7,   7,   4,   7,   7,  23,  14,  14,
31707      &    23,  14,  23,  23,  14,  14,   7,  23,  13,  23,
31708      &    14,  23,  14,  23,  13,  23,  13,  23,  14,  23,
31709      &    14,  23,  13,  23,  13,  23,  13,  33,  32,  35,
31710      &    31,  23,  14,  23,  14,  33,  34,  35,  31,  23,
31711      &    14,  23,  14,  33,  34,  35,  31,  23,  13,  23,
31712      &    13,  33,  32,  35,  31,  13,  13,  23,  23,  14,
31713      &    13,  14,  14,  25,  16,  14,  23,  13,  31,  14,
31714      &    13,  23,  25,  16,  23,  35,  33,  34,  32,  33,
31715      &    31,  31,  14,  13,  23,   0,   0,   0,   0,  13,
31716      &    23,  13,  14,  23,  14,  13,  23,  13,  78,  23,
31717      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31718      &    13,  80,  79,  14,  14,  23,  80,  31,  14,  23  /
31719       DATA (NZK(K,2),K=171,340) /
31720      &    13,  79,  78,  31,  14,  23,  13,  80,  79,  23,
31721      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31722      &    13,  80,  79,  23,  13,  33,  32,  15,  24,  15,
31723      &    31,  14,  23,  34,  33,  24,  24,  15,  31,  14,
31724      &    23,  14,  13,  23,  13,  14,  23,  14,  80,  23,
31725      &    14,  13,  23,  14,  79,  80,  13,  23,  13,  23,
31726      &    14,  78,  79,  13,  13,  23,  78,  23,  14,  13,
31727      &    23,  14,  79,  80,  13,  23,  13,  23,  14,  78,
31728      &    79,  62,  61,  23,  14,  23,  13,  13,  13,  23,
31729      &    13,  13,  23,  14,  14,  14,   1,   8,   8,   1,
31730      &     8,   1,   8,   8,   1,   8,   1,   8,   1,   8,
31731      &     1,   1,   8,   1,   8,   8,   1,   1,   8,   8,
31732      &     1,   8,  25,  23,  13,  31,  23,  13,  16,  14,
31733      &    35,  34,  34,  33,  31,  14,  23,   0,   0,   0,
31734      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31735      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31736      &    13,  23,  14,   7,  16,  19,  14,   7,  23,  14  /
31737       DATA (NZK(K,2),K=341,510) /
31738      &    23,  14,   7,  13,  23,  13,  13,  23,  13,  23,
31739      &    14,  13,  14,  23,  14,  23,  13,  14,  23,  14,
31740      &    23,  16,  14,  23,  14,  23,  14,  13,  13,  23,
31741      &    13,  23,  14,  13,  23,  13,  23,  15,  13,  13,
31742      &    13,  23,  13,  13,  14,  14,  14,  14,  14,  23,
31743      &    13,  16,  25,  14,  15,  24,  23,  14,   7,  23,
31744      &     7,  13,  23,   7,  14,  23,   7,  23,   7,   7,
31745      &     7,   7,   7,  13,  23,  31,   3,  11,  14, 135,
31746      &     5, 134, 134, 134, 136,   6, 133, 133, 133,   0,
31747      &     0,   0,   0,  31,  95,  25,  15,  31,  95,  16,
31748      &    32,  32,  33,  35,  39,  39,  38,  25,  13,  39,
31749      &    32,  39,  38,  35,  32,  39,  13,  23,  14,   7,
31750      &     7,  25,  37,  32,  13,  25,  13,  25,  13,  25,
31751      &    13,  31,  95,  24,  16,  31,  24,  15,  34,  34,
31752      &    33,  35,  37,  37,  36,  24,  14,  37,  34,  37,
31753      &    36,  35,  34,  37,  14,  23,  13,   7,   7,  24,
31754      &    39,  34,  14,  24,  14,  24,  14,  24,  14,   7  /
31755       DATA (NZK(K,2),K=511,540) /
31756      &     7,   7,   7,   7,   7,   7,   7,   7,  25,  13,
31757      &    25,   7,   7,   7,   7,   7,   7,   7,   7,   7,
31758      &    24,  14,  24,  13,  14,  23,  13,  23,  14,  23  /
31759       DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31760      & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31761      & 14, 14, 23, 14, 16, 25,
31762      & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31763      & 23, 13, 14, 23,  0 /
31764       DATA (NZK(K,3),K=  1,170) /
31765      &     0,   0,   0,   0,   0,   0,   0,   5,   6,   5,
31766      &     6,  23,  23,   5,   5,   0,   0,   0,   0,  14,
31767      &    23,   5,   5,   0,   0,  14,  23,   5,   5,   0,
31768      &     0,   5,   5,   0,   0,   5,   5,   0,   0,   0,
31769      &     0,   0,   0,   0,   3,   0,   7,  23,  23,   7,
31770      &     0,   0,   0,   0,  23,   0,   0,   0,   0,   0,
31771      &     110*0   /
31772       DATA (NZK(K,3),K=171,340) /
31773      &     80*0,
31774      &     0,   0,   0,   0,   0,   0,  23,  13,  14,  23,
31775      &    23,  14,  23,  23,  23,  14,  23,  13,  23,  14,
31776      &    13,  23,  13,  23,  14,  23,  14,  14,  23,  13,
31777      &    13,  23,  13,  14,  23,  23,  14,  23,  13,  23,
31778      &    14,  14,   0,   0,   0,   0,   0,   0,   0,   0,
31779      &     30*0,
31780      &    14,  23,   7,   0,   0,   0,  23,   0,   0,   0  /
31781       DATA (NZK(K,3),K=341,510) /
31782      &     30*0,
31783      &     0,   0,   0,   0,   0,   0,   0,   0,   0,  23,
31784      &    14,   0,  13,   0,  14,   0,   0,  23,  13,   0,
31785      &     0,  15,   0,   0,  16,   0,   0,   0,   0,   0,
31786      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31787      &     0,   0,   0,  14,  23,   0,   0,   0,  23, 134,
31788      &   134,   0,   0,   0, 133, 133,   0,   0,   0,   0,
31789      &     80*0  /
31790       DATA (NZK(K,3),K=511,540) /
31791      &     0,   0,   0,   0,   0,   0,   0,   0,  13,  13,
31792      &    25,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31793      &    14,  14,  24,   0,   0,   0,   0,   0,   0,   0  /
31794       DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31795      & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31796
31797       END
31798
31799 *$ CREATE DT_XHOINI.FOR
31800 *COPY DT_XHOINI
31801 *
31802 *====phoini============================================================*
31803 *
31804       SUBROUTINE DT_XHOINI
31805 C     SUBROUTINE DT_PHOINI
31806
31807       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31808       SAVE
31809
31810       PARAMETER ( LINP = 10 ,
31811      &            LOUT = 6 ,
31812      &            LDAT = 9 )
31813
31814       RETURN
31815       END
31816
31817 *$ CREATE DT_XVENTB.FOR
31818 *COPY DT_XVENTB
31819 *
31820 *====eventb============================================================*
31821 *
31822       SUBROUTINE DT_XVENTB(NCSY,IREJ)
31823 C     SUBROUTINE DT_EVENTB(NCSY,IREJ)
31824
31825       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31826       SAVE
31827
31828       PARAMETER ( LINP = 10 ,
31829      &            LOUT = 6 ,
31830      &            LDAT = 9 )
31831
31832       WRITE(LOUT,1000)
31833  1000 FORMAT(1X,'EVENTB:   PHOJET-package requested but not linked!')
31834       STOP
31835
31836       END
31837
31838 *$ CREATE DT_XVENT.FOR
31839 *COPY DT_XVENT
31840 *
31841 *===event==============================================================*
31842 *
31843       SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
31844 C     SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
31845
31846       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31847       SAVE
31848
31849       DIMENSION PP(4),PT(4)
31850
31851       RETURN
31852       END
31853
31854 *$ CREATE DT_XOHISX.FOR
31855 *COPY DT_XOHISX
31856 *
31857 *===pohisx=============================================================*
31858 *
31859       SUBROUTINE DT_XOHISX(I,X)
31860 C     SUBROUTINE POHISX(I,X)
31861
31862       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31863       SAVE
31864
31865       RETURN
31866       END
31867
31868 *$ CREATE PHO_LHIST.FOR
31869 *COPY PHO_LHIST
31870 *
31871 *===poluhi=============================================================*
31872 *
31873       SUBROUTINE PHO_LHIST(I,X)
31874
31875 **
31876
31877       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31878       SAVE
31879
31880       RETURN
31881       END
31882
31883 *$ CREATE PDFSET.FOR
31884 *COPY PDFSET
31885 *
31886 C**********************************************************************
31887 C
31888 C   dummy subroutines, remove to link PDFLIB
31889 C
31890 C**********************************************************************
31891       SUBROUTINE PDFSET(PARAM,VALUE)
31892       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31893       DIMENSION PARAM(20),VALUE(20)
31894       CHARACTER*20 PARAM
31895       END
31896
31897 *$ CREATE STRUCTM.FOR
31898 *COPY STRUCTM
31899 *
31900       SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31901       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31902       END
31903
31904 *$ CREATE STRUCTP.FOR
31905 *COPY STRUCTP
31906 *
31907       SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31908       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31909       END
31910
31911 *$ CREATE DT_DIQBRK.FOR
31912 *COPY DT_DIQBRK
31913 *
31914 *===diqbrk=============================================================*
31915 *
31916       SUBROUTINE DT_XIQBRK
31917 C     SUBROUTINE DT_DIQBRK
31918
31919       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31920       SAVE
31921
31922       STOP 'diquark-breaking not implemeted !'
31923
31924       RETURN
31925       END
31926 *$ CREATE DT_ELHAIN.FOR
31927 *COPY DT_ELHAIN
31928 *
31929 *===elhain=============================================================*
31930 *
31931       SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
31932
31933 ************************************************************************
31934 * Elastic hadron-hadron scattering.                                    *
31935 * This is a revised version of the original.                           *
31936 * This version dated 03.04.98 is written by S. Roesler                 *
31937 ************************************************************************
31938
31939       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31940       SAVE
31941
31942       PARAMETER ( LINP = 10 ,
31943      &            LOUT = 6 ,
31944      &            LDAT = 9 )
31945
31946       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
31947      &           TINY10=1.0D-10)
31948
31949       PARAMETER (ENNTHR = 3.5D0)
31950       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
31951      &           BLOWB=0.05D0,BHIB=0.2D0,
31952      &           BLOWM=0.1D0, BHIM=2.0D0)
31953
31954 * particle properties (BAMJET index convention)
31955       CHARACTER*8  ANAME
31956       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31957      &                IICH(210),IIBAR(210),K1(210),K2(210)
31958
31959 * final state from HADRIN interaction
31960       PARAMETER (MAXFIN=10)
31961       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
31962      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
31963
31964 C     DATA TSLOPE /10.0D0/
31965
31966       IREJ = 0
31967
31968     1 CONTINUE
31969
31970       PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
31971       EKIN = ELAB-AAM(IP)
31972 *   kinematical quantities in cms of the hadrons
31973       AMP2 = AAM(IP)**2
31974       AMT2 = AAM(IT)**2
31975       S    = AMP2+AMT2+TWO*ELAB*AAM(IT)
31976       ECM  = SQRT(S)
31977       ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
31978       PCM  = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
31979
31980 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
31981       IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
31982      &     ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
31983 *   TSAMCS treats pp and np only, therefore change pn into np and
31984 *   nn into pp
31985          IF (IT.EQ.1) THEN
31986             KPROJ = IP
31987          ELSE
31988             KPROJ = 8
31989             IF (IP.EQ.8) KPROJ = 1
31990          ENDIF
31991          CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
31992          T = TWO*PCM**2*(CTCMS-ONE)
31993
31994 * very crude treatment otherwise: sample t from exponential dist.
31995       ELSE
31996 *   momentum transfer t
31997          TMAX = TWO*TWO*PCM**2
31998          RR = (PLAB-PLOWH)/(PHIH-PLOWH)
31999          IF (IIBAR(IP).NE.0) THEN
32000             TSLOPE = BLOWB+RR*(BHIB-BLOWB)
32001          ELSE
32002             TSLOPE = BLOWM+RR*(BHIM-BLOWM)
32003          ENDIF
32004          FMAX = EXP(-TSLOPE*TMAX)-ONE
32005          R = DT_RNDM(RR)
32006          T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
32007          IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
32008       ENDIF
32009
32010 *   target hadron in Lab after scattering
32011       ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
32012       PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
32013       IF (PLRH(2).LE.TINY10) THEN
32014 C        WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
32015          GOTO 1
32016       ENDIF
32017 *   projectile hadron in Lab after scattering
32018       ELRH(1) = ELAB+AAM(IT)-ELRH(2)
32019       PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
32020 *   scattering angle of projectile in Lab
32021       CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
32022       STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
32023       CALL DT_DSFECF(SPLABP,CPLABP)
32024 *   direction cosines of projectile in Lab
32025       CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
32026      &                          CXRH(1),CYRH(1),CZRH(1))
32027 *   scattering angle of target in Lab
32028       PLLABT = PLAB-CTLABP*PLRH(1)
32029       CTLABT = PLLABT/PLRH(2)
32030       STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
32031 *   direction cosines of target in Lab
32032       CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
32033      &                            CXRH(2),CYRH(2),CZRH(2))
32034 *   fill /HNFSPA/
32035       IRH = 2
32036       ITRH(1) = IP
32037       ITRH(2) = IT
32038
32039       RETURN
32040       END
32041
32042 *$ CREATE DT_TSAMCS.FOR
32043 *COPY DT_TSAMCS
32044 *
32045 *===tsamcs=============================================================*
32046 *
32047       SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
32048
32049 ************************************************************************
32050 * Sampling of cos(theta) for nucleon-proton scattering according to    *
32051 * hetkfa2/bertini parametrization.                                     *
32052 * This is a revised version of the original (HJM 24/10/88)             *
32053 * This version dated 28.10.95 is written by S. Roesler                 *
32054 ************************************************************************
32055
32056       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32057       SAVE
32058
32059       PARAMETER ( LINP = 10 ,
32060      &            LOUT = 6 ,
32061      &            LDAT = 9 )
32062
32063       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
32064      &           TINY10=1.0D-10)
32065
32066       DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
32067       DIMENSION PDCI(60),PDCH(55)
32068
32069       DATA (DCLIN(I),I=1,80) /
32070      &     5.000D-01,  1.000D+00,  0.000D+00,  1.000D+00,  0.000D+00,
32071      &     4.993D-01,  9.881D-01,  5.963D-02,  9.851D-01,  5.945D-02,
32072      &     4.936D-01,  8.955D-01,  5.224D-01,  8.727D-01,  5.091D-01,
32073      &     4.889D-01,  8.228D-01,  8.859D-01,  7.871D-01,  8.518D-01,
32074      &     4.874D-01,  7.580D-01,  1.210D+00,  7.207D-01,  1.117D+00,
32075      &     4.912D-01,  6.969D-01,  1.516D+00,  6.728D-01,  1.309D+00,
32076      &     5.075D-01,  6.471D-01,  1.765D+00,  6.667D-01,  1.333D+00,
32077      &     5.383D-01,  6.054D-01,  1.973D+00,  7.059D-01,  1.176D+00,
32078      &     5.397D-01,  5.990D-01,  2.005D+00,  7.023D-01,  1.191D+00,
32079      &     5.336D-01,  6.083D-01,  1.958D+00,  6.959D-01,  1.216D+00,
32080      &     5.317D-01,  6.075D-01,  1.962D+00,  6.897D-01,  1.241D+00,
32081      &     5.300D-01,  6.016D-01,  1.992D+00,  6.786D-01,  1.286D+00,
32082      &     5.281D-01,  6.063D-01,  1.969D+00,  6.786D-01,  1.286D+00,
32083      &     5.280D-01,  5.960D-01,  2.020D+00,  6.667D-01,  1.333D+00,
32084      &     5.273D-01,  5.920D-01,  2.040D+00,  6.604D-01,  1.358D+00,
32085      &     5.273D-01,  5.862D-01,  2.069D+00,  6.538D-01,  1.385D+00/
32086       DATA (DCLIN(I),I=81,160) /
32087      &     5.223D-01,  5.980D-01,  2.814D+00,  6.538D-01,  1.385D+00,
32088      &     5.202D-01,  5.969D-01,  2.822D+00,  6.471D-01,  1.412D+00,
32089      &     5.183D-01,  5.881D-01,  2.883D+00,  6.327D-01,  1.469D+00,
32090      &     5.159D-01,  5.866D-01,  2.894D+00,  6.250D-01,  1.500D+00,
32091      &     5.133D-01,  5.850D-01,  2.905D+00,  6.170D-01,  1.532D+00,
32092      &     5.106D-01,  5.833D-01,  2.917D+00,  6.087D-01,  1.565D+00,
32093      &     5.084D-01,  5.801D-01,  2.939D+00,  6.000D-01,  1.600D+00,
32094      &     5.063D-01,  5.763D-01,  2.966D+00,  5.909D-01,  1.636D+00,
32095      &     5.036D-01,  5.730D-01,  2.989D+00,  5.814D-01,  1.674D+00,
32096      &     5.014D-01,  5.683D-01,  3.022D+00,  5.714D-01,  1.714D+00,
32097      &     4.986D-01,  5.641D-01,  3.051D+00,  5.610D-01,  1.756D+00,
32098      &     4.964D-01,  5.580D-01,  3.094D+00,  5.500D-01,  1.800D+00,
32099      &     4.936D-01,  5.573D-01,  3.099D+00,  5.431D-01,  1.827D+00,
32100      &     4.909D-01,  5.509D-01,  3.144D+00,  5.313D-01,  1.875D+00,
32101      &     4.885D-01,  5.512D-01,  3.142D+00,  5.263D-01,  1.895D+00,
32102      &     4.857D-01,  5.437D-01,  3.194D+00,  5.135D-01,  1.946D+00/
32103       DATA (DCLIN(I),I=161,195) /
32104      &     4.830D-01,  5.353D-01,  3.253D+00,  5.000D-01,  2.000D+00,
32105      &     4.801D-01,  5.323D-01,  3.274D+00,  4.915D-01,  2.034D+00,
32106      &     4.770D-01,  5.228D-01,  3.341D+00,  4.767D-01,  2.093D+00,
32107      &     4.738D-01,  5.156D-01,  3.391D+00,  4.643D-01,  2.143D+00,
32108      &     4.701D-01,  5.010D-01,  3.493D+00,  4.444D-01,  2.222D+00,
32109      &     4.672D-01,  4.990D-01,  3.507D+00,  4.375D-01,  2.250D+00,
32110      &     4.634D-01,  4.856D-01,  3.601D+00,  4.194D-01,  2.323D+00/
32111
32112       DATA PDCI /
32113      &     4.400D+02,  1.896D-01,  1.931D-01,  1.982D-01,  1.015D-01,
32114      &     1.029D-01,  4.180D-02,  4.228D-02,  4.282D-02,  4.350D-02,
32115      &     2.204D-02,  2.236D-02,  5.900D+02,  1.433D-01,  1.555D-01,
32116      &     1.774D-01,  1.000D-01,  1.128D-01,  5.132D-02,  5.600D-02,
32117      &     6.158D-02,  6.796D-02,  3.660D-02,  3.820D-02,  6.500D+02,
32118      &     1.192D-01,  1.334D-01,  1.620D-01,  9.527D-02,  1.141D-01,
32119      &     5.283D-02,  5.952D-02,  6.765D-02,  7.878D-02,  4.796D-02,
32120      &     6.957D-02,  8.000D+02,  4.872D-02,  6.694D-02,  1.152D-01,
32121      &     9.348D-02,  1.368D-01,  6.912D-02,  7.953D-02,  9.577D-02,
32122      &     1.222D-01,  7.755D-02,  9.525D-02,  1.000D+03,  3.997D-02,
32123      &     5.456D-02,  9.804D-02,  8.084D-02,  1.208D-01,  6.520D-02,
32124      &     8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,  1.093D-01/
32125
32126       DATA PDCH /
32127      &     1.000D+03,  9.453D-02,  9.804D-02,  8.084D-02,  1.208D-01,
32128      &     6.520D-02,  8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,
32129      &     1.093D-01,  1.400D+03,  1.072D-01,  7.450D-02,  6.645D-02,
32130      &     1.136D-01,  6.750D-02,  8.580D-02,  1.110D-01,  1.530D-01,
32131      &     1.010D-01,  1.350D-01,  2.170D+03,  4.004D-02,  3.013D-02,
32132      &     2.664D-02,  5.511D-02,  4.240D-02,  7.660D-02,  1.364D-01,
32133      &     2.300D-01,  1.670D-01,  2.010D-01,  2.900D+03,  1.870D-02,
32134      &     1.804D-02,  1.320D-02,  2.970D-02,  2.860D-02,  5.160D-02,
32135      &     1.020D-01,  2.400D-01,  2.250D-01,  3.370D-01,  4.400D+03,
32136      &     1.196D-03,  8.784D-03,  1.517D-02,  2.874D-02,  2.488D-02,
32137      &     4.464D-02,  8.330D-02,  2.008D-01,  2.360D-01,  3.567D-01/
32138
32139       DATA (DCHN(I),I=1,90) /
32140      &     4.770D-01,  4.750D-01,  4.715D-01,  4.685D-01,  4.650D-01,
32141      &     4.610D-01,  4.570D-01,  4.550D-01,  4.500D-01,  4.450D-01,
32142      &     4.405D-01,  4.350D-01,  4.300D-01,  4.250D-01,  4.200D-01,
32143      &     4.130D-01,  4.060D-01,  4.000D-01,  3.915D-01,  3.840D-01,
32144      &     3.760D-01,  3.675D-01,  3.580D-01,  3.500D-01,  3.400D-01,
32145      &     3.300D-01,  3.200D-01,  3.100D-01,  3.000D-01,  2.900D-01,
32146      &     2.800D-01,  2.700D-01,  2.600D-01,  2.500D-01,  2.400D-01,
32147      &     2.315D-01,  2.240D-01,  2.150D-01,  2.060D-01,  2.000D-01,
32148      &     1.915D-01,  1.850D-01,  1.780D-01,  1.720D-01,  1.660D-01,
32149      &     1.600D-01,  1.550D-01,  1.500D-01,  1.450D-01,  1.400D-01,
32150      &     1.360D-01,  1.320D-01,  1.280D-01,  1.250D-01,  1.210D-01,
32151      &     1.180D-01,  1.150D-01,  1.120D-01,  1.100D-01,  1.070D-01,
32152      &     1.050D-01,  1.030D-01,  1.010D-01,  9.900D-02,  9.700D-02,
32153      &     9.550D-02,  9.480D-02,  9.400D-02,  9.200D-02,  9.150D-02,
32154      &     9.100D-02,  9.000D-02,  8.990D-02,  8.900D-02,  8.850D-02,
32155      &     8.750D-02,  8.700D-02,  8.650D-02,  8.550D-02,  8.500D-02,
32156      &     8.499D-02,  8.450D-02,  8.350D-02,  8.300D-02,  8.250D-02,
32157      &     8.150D-02,  8.100D-02,  8.030D-02,  8.000D-02,  7.990D-02/
32158       DATA (DCHN(I),I=91,143) /
32159      &     7.980D-02,  7.950D-02,  7.900D-02,  7.860D-02,  7.800D-02,
32160      &     7.750D-02,  7.650D-02,  7.620D-02,  7.600D-02,  7.550D-02,
32161      &     7.530D-02,  7.500D-02,  7.499D-02,  7.498D-02,  7.480D-02,
32162      &     7.450D-02,  7.400D-02,  7.350D-02,  7.300D-02,  7.250D-02,
32163      &     7.230D-02,  7.200D-02,  7.100D-02,  7.050D-02,  7.020D-02,
32164      &     7.000D-02,  6.999D-02,  6.995D-02,  6.993D-02,  6.991D-02,
32165      &     6.990D-02,  6.870D-02,  6.850D-02,  6.800D-02,  6.780D-02,
32166      &     6.750D-02,  6.700D-02,  6.650D-02,  6.630D-02,  6.600D-02,
32167      &     6.550D-02,  6.525D-02,  6.510D-02,  6.500D-02,  6.499D-02,
32168      &     6.498D-02,  6.496D-02,  6.494D-02,  6.493D-02,  6.490D-02,
32169      &     6.488D-02,  6.485D-02,  6.480D-02/
32170
32171       DATA DCHNA /
32172      &     6.300D+02,  7.810D-02,  1.421D-01,  1.979D-01,  2.479D-01,
32173      &     3.360D-01,  5.400D-01,  7.236D-01,  1.000D+00,  1.540D+03,
32174      &     2.225D-01,  3.950D-01,  5.279D-01,  6.298D-01,  7.718D-01,
32175      &     9.405D-01,  9.835D-01,  1.000D+00,  2.560D+03,  2.625D-01,
32176      &     4.550D-01,  5.963D-01,  7.020D-01,  8.380D-01,  9.603D-01,
32177      &     9.903D-01,  1.000D+00,  3.520D+03,  4.250D-01,  6.875D-01,
32178      &     8.363D-01,  9.163D-01,  9.828D-01,  1.000D+00,  1.000D+00,
32179      &     1.000D+00/
32180
32181       DATA DCHNB /
32182      &     6.300D+02,  3.800D-02,  7.164D-02,  1.275D-01,  2.171D-01,
32183      &     3.227D-01,  4.091D-01,  5.051D-01,  6.061D-01,  7.074D-01,
32184      &     8.434D-01,  1.000D+00,  2.040D+03,  1.200D-01,  2.115D-01,
32185      &     3.395D-01,  5.295D-01,  7.251D-01,  8.511D-01,  9.487D-01,
32186      &     9.987D-01,  1.000D+00,  1.000D+00,  1.000D+00,  2.200D+03,
32187      &     1.344D-01,  2.324D-01,  3.754D-01,  5.674D-01,  7.624D-01,
32188      &     8.896D-01,  9.808D-01,  1.000D+00,  1.000D+00,  1.000D+00,
32189      &     1.000D+00,  2.850D+03,  2.330D-01,  4.130D-01,  6.610D-01,
32190      &     9.010D-01,  9.970D-01,  1.000D+00,  1.000D+00,  1.000D+00,
32191      &     1.000D+00,  1.000D+00,  1.000D+00,  3.500D+03,  3.300D-01,
32192      &     5.450D-01,  7.950D-01,  1.000D+00,  1.000D+00,  1.000D+00,
32193      &     1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00/
32194
32195       CST = ONE
32196       IF (EKIN.GT.3.5D0) RETURN
32197 C
32198       IF(KPROJ.EQ.8) GOTO 101
32199       IF(KPROJ.EQ.1) GOTO 102
32200 C*                                             INVALID REACTION
32201       WRITE(LOUT,'(A,I5/A)')
32202      &        ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
32203      &        ' COS(THETA) = 1D0 RETURNED'
32204       RETURN
32205 C-------------------------------- NP ELASTIC SCATTERING----------
32206 101   CONTINUE
32207       IF (EKIN.GT.0.740D0)GOTO 1000
32208       IF (EKIN.LT.0.300D0)THEN
32209 C                                 EKIN .LT. 300 MEV
32210          IDAT=1
32211       ELSE
32212 C                                 300 MEV < EKIN < 740 MEV
32213          IDAT=6
32214       END IF
32215 C
32216       ENER=EKIN
32217       IE=INT(ABS(ENER/0.020D0))
32218       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32219 C                                            FORWARD/BACKWARD DECISION
32220       K=IDAT+5*IE
32221       BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32222       IF (DT_RNDM(CST).LT.BWFW)THEN
32223          VALUE2=-1D0
32224          K=K+1
32225       ELSE
32226          VALUE2=1D0
32227          K=K+3
32228       END IF
32229 C
32230       COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32231       RND=DT_RNDM(COEF)
32232 C
32233       IF(RND.LT.COEF)THEN
32234          CST=DT_RNDM(RND)
32235          CST=CST*VALUE2
32236       ELSE
32237          R1=DT_RNDM(CST)
32238          R2=DT_RNDM(R1)
32239          R3=DT_RNDM(R2)
32240          R4=DT_RNDM(R3)
32241 C
32242          IF(VALUE2.GT.0.0)THEN
32243             CST=MAX(R1,R2,R3,R4)
32244             GOTO 1500
32245          ELSE
32246             R5=DT_RNDM(R4)
32247 C
32248             IF (IDAT.EQ.1)THEN
32249                CST=-MAX(R1,R2,R3,R4,R5)
32250             ELSE
32251                R6=DT_RNDM(R5)
32252                R7=DT_RNDM(R6)
32253                CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
32254             END IF
32255 C
32256          END IF
32257 C
32258       END IF
32259 C
32260       GOTO 1500
32261 C
32262 C********                                EKIN  .GT.  0.74 GEV
32263 C
32264 1000  ENER=EKIN - 0.66D0
32265 C     IE=ABS(ENER/0.02)
32266       IE=INT(ENER/0.02D0)
32267       EMEV=EKIN*1D3
32268 C
32269       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32270       K=IE
32271       BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
32272       RND=DT_RNDM(BWFW)
32273 C                                        FORWARD NEUTRON
32274       IF (RND.GE.BWFW)THEN
32275          DO 1200 K=10,36,9
32276            IF (DCHNA(K).GT.EMEV) THEN
32277               UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
32278               UNIV=DT_RNDM(UNIVE)
32279               DO 1100 I=1,8
32280                  II=K+I
32281                  P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
32282 C
32283                  IF (P.GT.UNIV)THEN
32284                     UNIV=DT_RNDM(UNIVE)
32285                     FLTI=DBLE(I)-UNIV
32286                     GOTO(290,290,290,290,330,340,350,360) I
32287                  END IF
32288  1100         CONTINUE
32289            END IF
32290  1200    CONTINUE
32291 C
32292       ELSE
32293 C                                        BACKWARD NEUTRON
32294          DO 1400 K=13,60,12
32295             IF (DCHNB(K).GT.EMEV) THEN
32296                UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
32297                UNIV=DT_RNDM(UNIVE)
32298                DO 1300 I=1,11
32299                  II=K+I
32300                  P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
32301 C
32302                  IF (P.GT.UNIV)THEN
32303                    UNIV=DT_RNDM(P)
32304                    FLTI=DBLE(I)-UNIV
32305                    GOTO(120,120,140,150,160,160,180,190,200,210,220) I
32306                  END IF
32307  1300          CONTINUE
32308             END IF
32309  1400    CONTINUE
32310       END IF
32311 C
32312 120   CST=1.0D-2*FLTI-1.0D0
32313       GOTO 1500
32314 140   CST=2.0D-2*UNIV-0.98D0
32315       GOTO 1500
32316 150   CST=4.0D-2*UNIV-0.96D0
32317       GOTO 1500
32318 160   CST=6.0D-2*FLTI-1.16D0
32319       GOTO 1500
32320 180   CST=8.0D-2*UNIV-0.80D0
32321       GOTO 1500
32322 190   CST=1.0D-1*UNIV-0.72D0
32323       GOTO 1500
32324 200   CST=1.2D-1*UNIV-0.62D0
32325       GOTO 1500
32326 210   CST=2.0D-1*UNIV-0.50D0
32327       GOTO 1500
32328 220   CST=3.0D-1*(UNIV-1.0D0)
32329       GOTO 1500
32330 C
32331 290   CST=1.0D0-2.5d-2*FLTI
32332       GOTO 1500
32333 330   CST=0.85D0+0.5D-1*UNIV
32334       GOTO 1500
32335 340   CST=0.70D0+1.5D-1*UNIV
32336       GOTO 1500
32337 350   CST=0.50D0+2.0D-1*UNIV
32338       GOTO 1500
32339 360   CST=0.50D0*UNIV
32340 C
32341 1500  RETURN
32342 C
32343 C-----------------------------------  PP ELASTIC SCATTERING -------
32344 C
32345  102  CONTINUE
32346       EMEV=EKIN*1D3
32347 C
32348       IF (EKIN.LE.0.500D0) THEN
32349          RND=DT_RNDM(EMEV)
32350          CST=2.0D0*RND-1.0D0
32351          RETURN
32352 C
32353       ELSEIF (EKIN.LT.1.0D0) THEN
32354          DO 2200 K=13,60,12
32355             IF (PDCI(K).GT.EMEV) THEN
32356                UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
32357                UNIV=DT_RNDM(UNIVE)
32358                SUM=0
32359                DO 2100 I=1,11
32360                  II=K+I
32361                  SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
32362 C
32363                  IF (UNIV.LT.SUM)THEN
32364                    UNIV=DT_RNDM(SUM)
32365                    FLTI=DBLE(I)-UNIV
32366                    GOTO(55,55,55,60,60,65,65,65,65,70,70) I
32367                  END IF
32368  2100          CONTINUE
32369             END IF
32370  2200    CONTINUE
32371       ELSE
32372          DO 2400 K=12,55,11
32373             IF (PDCH(K).GT.EMEV) THEN
32374               UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
32375               UNIV=DT_RNDM(UNIVE)
32376               SUM=0.0D0
32377               DO 2300 I=1,10
32378                 II=K+I
32379                 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
32380 C
32381                 IF (UNIV.LT.SUM)THEN
32382                   UNIV=DT_RNDM(SUM)
32383                   FLTI=UNIV+DBLE(I)
32384                   GOTO(50,55,60,60,65,65,65,65,70,70) I
32385                 END IF
32386  2300         CONTINUE
32387             END IF
32388  2400    CONTINUE
32389       END IF
32390 C
32391 50    CST=0.4D0*UNIV
32392       GOTO 2500
32393 55    CST=0.2D0*FLTI
32394       GOTO 2500
32395 60    CST=0.3D0+0.1D0*FLTI
32396       GOTO 2500
32397 65    CST=0.6D0+0.04D0*FLTI
32398       GOTO 2500
32399 70    CST=0.78D0+0.02D0*FLTI
32400 C
32401 2500  CONTINUE
32402       IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
32403 C
32404       RETURN
32405       END
32406
32407 *$ CREATE DT_DHADRI.FOR
32408 *COPY DT_DHADRI
32409 *
32410 *===dhadri=============================================================*
32411 *
32412       SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
32413
32414       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32415       SAVE
32416
32417       PARAMETER ( LINP = 10 ,
32418      &            LOUT = 6 ,
32419      &            LDAT = 9 )
32420
32421 C
32422 C-----------------------------
32423 C*** INPUT VARIABLES LIST:
32424 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
32425 C*** GEV/C LABORATORY MOMENTUM REGION
32426 C*** N    - PROJECTILE HADRON INDEX
32427 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
32428 C*** ELAB - LABORATORY ENERGY OF N (GEV)
32429 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
32430 C*** ITTA - TARGET NUCLEON INDEX
32431 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
32432 C  IR COUNTS THE NUMBER OF PRODUCED PARTICLES
32433 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
32434 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
32435 C*** RESPECT., UNITS (GEV/C AND GEV)
32436 C----------------------------
32437
32438       COMMON /HNGAMR/ REDU,AMO,AMM(15)
32439
32440       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32441
32442       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32443      &                NRK(2,268),NURE(30,2)
32444
32445 * particle properties (BAMJET index convention),
32446 * (dublicate of DTPART for HADRIN)
32447       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32448      &                K1H(110),K2H(110)
32449
32450       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32451
32452       COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
32453      &                ITS(149),IS
32454
32455       COMMON /HNDRUN/ RUNTES,EFTES
32456
32457 * particle properties (BAMJET index convention)
32458       CHARACTER*8  ANAME
32459       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
32460      &                IICH(210),IIBAR(210),K1(210),K2(210)
32461
32462 * final state from HADRIN interaction
32463       PARAMETER (MAXFIN=10)
32464       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
32465      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
32466
32467       DIMENSION ITPRF(110)
32468       DATA NNN/0/
32469       DATA UMODA/0./
32470       DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
32471       LOWP=0
32472       IF (N.LE.0.OR.N.GE.111)N=1
32473       IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
32474         GOTO 280
32475 *       WRITE (6,1000)
32476 *    +  ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
32477 *       STOP
32478 *1000   FORMAT (3(5H ****/),A,2I4,3(5H ****/))
32479 *    +  45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
32480       ENDIF
32481       IATMPT=0
32482       IF (ABS(PLAB-5.0D0).LT.4.99999D0)                        GO TO 20
32483 C     IF(IPRI.GE.1) WRITE (6,1010) PLAB
32484 C     STOP
32485  1010 FORMAT ( '  PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
32486      + ALLOWED REGION, PLAB=',1E15.5)
32487
32488    20 CONTINUE
32489       UMODAT=N*1.11111D0+ITTA*2.19291D0
32490       IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
32491       UMODA=UMODAT
32492    30 IATMPT=0
32493       LOWP=LOWP+1
32494    40 CONTINUE
32495       IMACH=0
32496       REDU=2.0D0
32497       IF (LOWP.GT.20) THEN
32498 C        WRITE(LOUT,*) ' jump 1'
32499          GO TO 280
32500       ENDIF
32501       NNN=N
32502       IF (NNN.EQ.N)                                             GO TO 50
32503       RUNTES=0.0D0
32504       EFTES=0.0D0
32505    50 CONTINUE
32506       IS=1
32507       IRH=0
32508       IST=1
32509       NSTAB=23
32510       IRE=NURE(N,1)
32511       IF(ITTA.GT.1) IRE=NURE(N,2)
32512 C
32513 C-----------------------------
32514 C*** IE,AMT,ECM,SI DETERMINATION
32515 C----------------------------
32516       CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
32517       IANTH=-1
32518 **sr
32519 C     IF (AMH(1).NE.0.93828D0) IANTH=1
32520       IF (AMH(1).NE.0.9383D0) IANTH=1
32521 **
32522       IF (IANTH.GE.0) SI=1.0D0
32523       ECMMH=ECM
32524 C
32525 C-----------------------------
32526 C    ENERGY INDEX
32527 C  IRE CHARACTERIZES THE REACTION
32528 C  IE IS THE ENERGY INDEX
32529 C----------------------------
32530       IF (SI.LT.1.D-6) THEN
32531 C        WRITE(LOUT,*) ' jump 2'
32532          GO TO 280
32533       ENDIF
32534       IF (N.LE.NSTAB)                                           GO TO 60
32535       RUNTES=RUNTES+1.0D0
32536       IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
32537  1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
32538       IF(IBARH(N).EQ.1) N=8
32539       IF(IBARH(N).EQ.-1)  N=9
32540    60 CONTINUE
32541       IMACH=IMACH+1
32542 **sr 19.2.97: loop for direct channel suppression
32543 C     IF (IMACH.GT.10) THEN
32544       IF (IMACH.GT.1000) THEN
32545 **
32546 C        WRITE(LOUT,*) ' jump 3'
32547          GO TO 280
32548       ENDIF
32549       ECM =ECMMH
32550       AMN2=AMN**2
32551       AMT2=AMT**2
32552       ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM    )
32553       IF(ECMN.LE.AMN) ECMN=AMN
32554       PCMN=SQRT(ECMN**2-AMN2)
32555       GAM=(ELAB+AMT)/ECM
32556       BGAM=PLAB/ECM
32557       IF (IANTH.GE.0) ECM=2.1D0
32558 C
32559 C-----------------------------
32560 C*** RANDOM CHOICE OF REACTION CHANNEL
32561 C----------------------------
32562       IST=0
32563       VV=DT_RNDM(AMN2)
32564       VV=VV-1.D-17
32565 C
32566 C-----------------------------
32567 C***  PLACE REDUCED VERSION
32568 C----------------------------
32569       IIEI=IEII(IRE)
32570       IDWK=IEII(IRE+1)-IIEI
32571       IIWK=IRII(IRE)
32572       IIKI=IKII(IRE)
32573 C
32574 C-----------------------------
32575 C***  SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
32576 C----------------------------
32577       HECM=ECM
32578       HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
32579       IF (HUMO.LT.ECM) ECM=HUMO
32580 C
32581 C-----------------------------
32582 C*** INTERPOLATION PREPARATION
32583 C----------------------------
32584       ECMO=UMO(IE)
32585       ECM1=UMO(IE-1)
32586       DECM=ECMO-ECM1
32587       DEC=ECMO-ECM
32588 C
32589 C-----------------------------
32590 C*** RANDOM LOOP
32591 C----------------------------
32592       IK=0
32593       WKK=0.0D0
32594       WICOR=0.0D0
32595    70 IK=IK+1
32596       IWK=IIWK+(IK-1)*IDWK+IE-IIEI
32597       WOK=WK(IWK)
32598       WDK=WOK-WK(IWK-1)
32599 C
32600 C-----------------------------
32601 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
32602 C    GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
32603 C    CONTRIBUTE
32604 C----------------------------
32605       IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
32606       WICO=WOK*1.23459876D0+WDK*1.735218469D0
32607       IF (WICO.EQ.WICOR)                                        GO TO 70
32608       IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
32609       WICOR=WICO
32610 C
32611 C-----------------------------
32612 C*** INTERPOLATION IN CHANNEL WEIGHTS
32613 C----------------------------
32614       EKLIM=-THRESH(IIKI+IK)
32615       IELIM=IDT_IEFUND(EKLIM,IRE)
32616       DELIM=UMO(IELIM)+EKLIM
32617      *+1.D-16
32618       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
32619       IF (DELIM*DELIM-DETE*DETE) 90,90,80
32620    80 DECC=DELIM
32621                                                                GO TO 100
32622    90 DECC=DECM
32623   100 CONTINUE
32624       WKK=WOK-WDK*DEC/(DECC+1.D-9)
32625 C
32626 C-----------------------------
32627 C*** RANDOM CHOICE
32628 C----------------------------
32629 C
32630       IF (VV.GT.WKK)                                            GO TO 70
32631 C
32632 C***IK IS THE REACTION CHANNEL
32633 C----------------------------
32634       INRK=IKII(IRE)+IK
32635       ECM=HECM
32636       I1001 =0
32637 C
32638   110 CONTINUE
32639       IT1=NRK(1,INRK)
32640       AM1=DT_DAMG(IT1)
32641       IT2=NRK(2,INRK)
32642       AM2=DT_DAMG(IT2)
32643       AMS=AM1+AM2
32644       I1001=I1001+1
32645       IF (I1001.GT.50)                                          GO TO 60
32646 C
32647       IF (IT2*AMS.GT.IT2*ECM)                                  GO TO 110
32648       IT11=IT1
32649       IT22=IT2
32650       IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
32651       AM11=AM1
32652       AM22=AM2
32653       IF (IT2.GT.0)                                            GO TO 120
32654 **sr 19.2.97: supress direct channel for pp-collisions
32655       IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
32656          RR = DT_RNDM(AM11)
32657          IF (RR.LE.0.75D0) GOTO 60
32658       ENDIF
32659 **
32660 C
32661 C-----------------------------
32662 C  INCLUSION OF DIRECT RESONANCES
32663 C  RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE  IT1
32664 C------------------------
32665       KZ1=K1H(IT1)
32666       IST=IST+1
32667       IECO=0
32668       ECO=ECM
32669       GAM=(ELAB+AMT)/ECO
32670       BGAM=PLAB/ECO
32671       CXS(1)=CX
32672       CYS(1)=CY
32673       CZS(1)=CZ
32674                                                                GO TO 170
32675   120 CONTINUE
32676       WW=DT_RNDM(ECO)
32677       IF(WW.LT. 0.5D0)                                         GO TO 130
32678       IT1=IT22
32679       IT2=IT11
32680       AM1=AM22
32681       AM2=AM11
32682   130 CONTINUE
32683 C
32684 C-----------------------------
32685 C   THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
32686       IBN=IBARH(N)
32687       IB1=IBARH(IT1)
32688       IT11=IT1
32689       IT22=IT2
32690       AM11=AM1
32691       AM22=AM2
32692       IF(IB1.EQ.IBN)                                           GO TO 140
32693       IT1=IT22
32694       IT2=IT11
32695       AM1=AM22
32696       AM2=AM11
32697   140 CONTINUE
32698 C-----------------------------
32699 C***IT1,IT2 ARE THE CREATED PARTICLES
32700 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
32701 C------------------------
32702       CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
32703      *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
32704       IST=IST+1
32705       ITS(IST)=IT1
32706       AMM(IST)=AM1
32707 C
32708 C-----------------------------
32709 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
32710 C----------------------------
32711       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
32712      &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32713       IST=IST+1
32714       ITS(IST)=IT2
32715       AMM(IST)=AM2
32716       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
32717      *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32718   150 CONTINUE
32719 C
32720 C-----------------------------
32721 C***TEST   STABLE OR UNSTABLE
32722 C----------------------------
32723       IF(ITS(IST).GT.NSTAB)                                    GO TO 160
32724       IRH=IRH+1
32725 C
32726 C-----------------------------
32727 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
32728 C----------------------------
32729 C*    IF (REDU.LT.0.D0) GO TO 1009
32730       ITRH(IRH)=ITS(IST)
32731       PLRH(IRH)=PLS(IST)
32732       CXRH(IRH)=CXS(IST)
32733       CYRH(IRH)=CYS(IST)
32734       CZRH(IRH)=CZS(IST)
32735       ELRH(IRH)=ELS(IST)
32736       IST=IST-1
32737       IF(IST.GE.1)                                             GO TO 150
32738                                                                GO TO 260
32739   160 CONTINUE
32740 C
32741 C  RANDOM CHOICE OF DECAY CHANNELS
32742 C----------------------------
32743 C
32744       IT=ITS(IST)
32745       ECO=AMM(IST)
32746       GAM=ELS(IST)/ECO
32747       BGAM=PLS(IST)/ECO
32748       IECO=0
32749       KZ1=K1H(IT)
32750   170 CONTINUE
32751       IECO=IECO+1
32752       VV=DT_RNDM(GAM)
32753       VV=VV-1.D-17
32754       IIK=KZ1-1
32755   180 IIK=IIK+1
32756       IF (VV.GT.WTI(IIK))                                      GO TO 180
32757 C
32758 C  IIK IS THE DECAY CHANNEL
32759 C----------------------------
32760       IT1=NZKI(IIK,1)
32761       I310=0
32762   190 CONTINUE
32763       I310=I310+1
32764       AM1=DT_DAMG(IT1)
32765       IT2=NZKI(IIK,2)
32766       AM2=DT_DAMG(IT2)
32767       IF (IT2-1.LT.0)                                          GO TO 240
32768       IT3=NZKI(IIK,3)
32769       AM3=DT_DAMG(IT3)
32770       AMS=AM1+AM2+AM3
32771 C
32772 C  IF  IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
32773 C----------------------------
32774       IF (IECO.LE.10)                                          GO TO 200
32775       IATMPT=IATMPT+1
32776       IF(IATMPT.GT.3) THEN
32777 C        WRITE(LOUT,*) ' jump 4'
32778          GO TO 280
32779       ENDIF
32780                                                                 GO TO 40
32781   200 CONTINUE
32782       IF (I310.GT.50)                                          GO TO 170
32783       IF (AMS.GT.ECO)                                          GO TO 190
32784 C
32785 C  FOR THE DECAY CHANNEL
32786 C  IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM  IT
32787 C----------------------------
32788       IF (REDU.LT.0.D0)                                        GO TO 30
32789       ITWTHC=0
32790       REDU=2.0D0
32791       IF(IT3.EQ.0)                                             GO TO 220
32792   210 CONTINUE
32793       ITWTH=1
32794       CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
32795      *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
32796                                                                GO TO 230
32797   220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
32798      &COD2,COF2,SIF2,AM1,AM2)
32799       ITWTH=-1
32800       IT3=0
32801   230 CONTINUE
32802       ITWTHC=ITWTHC+1
32803       IF (REDU.GT.0.D0)                                        GO TO 240
32804       REDU=2.0D0
32805       IF (ITWTHC.GT.100)                                        GO TO 30
32806       IF (ITWTH) 220,220,210
32807   240 CONTINUE
32808       ITS(IST  )=IT1
32809       IF (IT2-1.LT.0)                                          GO TO 250
32810       ITS(IST+1)  =IT2
32811       ITS(IST+2)=IT3
32812       RX=CXS(IST)
32813       RY=CYS(IST)
32814       RZ=CZS(IST)
32815       AMM(IST)=AM1
32816       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
32817      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32818       IST=IST+1
32819       AMM(IST)=AM2
32820       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
32821      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32822       IF (IT3.LE.0)                                            GO TO 250
32823       IST=IST+1
32824       AMM(IST)=AM3
32825       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
32826      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32827   250 CONTINUE
32828                                                                GO TO 150
32829   260 CONTINUE
32830   270 CONTINUE
32831       RETURN
32832   280 CONTINUE
32833 C
32834 C----------------------------
32835 C
32836 C   ZERO CROSS SECTION CASE
32837 C----------------------------
32838 C
32839       IRH=1
32840       ITRH(1)=N
32841       CXRH(1)=CX
32842       CYRH(1)=CY
32843       CZRH(1)=CZ
32844       ELRH(1)=ELAB
32845       PLRH(1)=PLAB
32846       RETURN
32847       END
32848
32849 *$ CREATE DT_RUNTT.FOR
32850 *COPY DT_RUNTT
32851 *
32852 *===runtt==============================================================*
32853 *
32854       BLOCK DATA DT_RUNTT
32855
32856       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32857       SAVE
32858
32859       COMMON /HNDRUN/ RUNTES,EFTES
32860
32861       DATA RUNTES,EFTES /100.D0,100.D0/
32862
32863       END
32864
32865 *$ CREATE DT_NONAME.FOR
32866 *COPY DT_NONAME
32867 *
32868 *===noname=============================================================*
32869 *
32870       BLOCK DATA DT_NONAME
32871
32872       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32873       SAVE
32874
32875 * slope parameters for HADRIN interactions
32876       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
32877
32878       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32879
32880 C     DATAS     DATAS    DATAS      DATAS     DATAS
32881 C******          *********
32882       DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
32883      &           207, 224, 241, 252, 268 /
32884       DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
32885      &           220, 241, 262, 279, 296 /
32886       DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
32887      &           3364, 3507, 4011, 4368, 4725, 4912, 5184/
32888
32889 C
32890 C     MASSES FOR THE SLOPE B(M) IN GEV
32891 C     SLOPE B(M) FOR AN MESONIC SYSTEM
32892 C     SLOPE B(M) FOR A BARYONIC SYSTEM
32893
32894 *
32895       DATA SM,BBM,BBB/  0.8D0, 0.85D0,  0.9D0, 0.95D0, 1.D0,
32896      &     1.05D0,  1.1D0, 1.15D0,  1.2D0, 1.25D0,
32897      &      1.3D0,  1.35D0, 1.4D0,  1.45D0,  1.5D0,
32898      &     1.55D0,  1.6D0,  1.65D0, 1.7D0,   1.75D0,
32899      &      1.8D0,  1.85D0, 1.9D0,  1.95D0,  2.D0,
32900      &     15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
32901      &    12.35D0, 11.7D0, 10.85D0, 10.D0,  9.15D0,
32902      &      8.3D0,  7.8D0,  7.3D0,  7.25D0,  7.2D0,
32903      &     6.95D0,  6.7D0,  6.6D0,  6.5D0,   6.3D0,
32904      &      6.1D0,  5.85D0, 5.6D0,  5.35D0,  5.1D0,
32905      &      15.D0,   15.D0, 15.D0,  15.D0,   15.D0, 15.D0, 15.D0,
32906      &     14.2D0,  13.4D0, 12.6D0,
32907      &     11.8D0, 11.2D0, 10.6D0,  9.8D0,    9.D0,
32908      &     8.25D0,  7.5D0, 6.25D0,  5.D0,    4.5D0, 5*4.D0 /
32909 *
32910       END
32911
32912 *$ CREATE DT_DAMG.FOR
32913 *COPY DT_DAMG
32914 *
32915 *===damg===============================================================*
32916 *
32917       DOUBLE PRECISION FUNCTION DT_DAMG(IT)
32918
32919       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32920       SAVE
32921
32922 * particle properties (BAMJET index convention),
32923 * (dublicate of DTPART for HADRIN)
32924       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32925      &                K1H(110),K2H(110)
32926
32927       DIMENSION GASUNI(14)
32928       DATA GASUNI/
32929      *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
32930      *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
32931       DATA GAUNO/2.352D0/
32932       DATA GAUNON/2.4D0/
32933       DATA IO/14/
32934       DATA NSTAB/23/
32935
32936       I=1
32937       IF (IT.LE.0)                                              GO TO 30
32938       IF (IT.LE.NSTAB)                                          GO TO 20
32939       DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
32940       VV=DT_RNDM(DGAUNI)
32941       VV=VV*2.0D0-1.0D0+1.D-16
32942    10 CONTINUE
32943       VO=GASUNI(I)
32944       I=I+1
32945       V1=GASUNI(I)
32946       IF (VV.GT.V1)                                             GO TO 10
32947       UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
32948      &      (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
32949       DAM=GAH(IT)*UNIGA/GAUNO
32950       AAM=AMH(IT)+DAM
32951       DT_DAMG=AAM
32952       RETURN
32953    20 CONTINUE
32954       DT_DAMG=AMH(IT)
32955       RETURN
32956    30 CONTINUE
32957       DT_DAMG=0.0D0
32958       RETURN
32959       END
32960
32961 *$ CREATE DT_DCALUM.FOR
32962 *COPY DT_DCALUM
32963 *
32964 *===dcalum=============================================================*
32965 *
32966       SUBROUTINE DT_DCALUM(N,ITTA)
32967
32968       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32969       SAVE
32970
32971 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
32972
32973 * particle properties (BAMJET index convention),
32974 * (dublicate of DTPART for HADRIN)
32975       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32976      &                K1H(110),K2H(110)
32977
32978       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32979
32980       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32981
32982       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32983      &                NRK(2,268),NURE(30,2)
32984
32985       IRE=NURE(N,ITTA/8+1)
32986       IEO=IEII(IRE)+1
32987       IEE=IEII(IRE +1)
32988       AM1=AMH(N   )
32989       AM12=AM1**2
32990       AM2=AMH(ITTA)
32991       AM22=AM2**2
32992       DO 10 IE=IEO,IEE
32993         PLAB2=PLABF(IE)**2
32994         ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
32995         UMO(IE)=ELAB
32996    10 CONTINUE
32997       IKO=IKII(IRE)+1
32998       IKE=IKII(IRE +1)
32999       UMOO=UMO(IEO)
33000       DO 30 IK=IKO,IKE
33001         IF(NRK(2,IK).GT.0)                                      GO TO 30
33002         IKI=NRK(1,IK)
33003         AMSS=5.0D0
33004         K11=K1H(IKI)
33005         K22=K2H(IKI)
33006         DO 20 IK1=K11,K22
33007           IN=NZKI(IK1,1)
33008           AMS=AMH(IN)
33009           IN=NZKI(IK1,2)
33010           IF(IN.GT.0)AMS=AMS+AMH(IN)
33011           IN=NZKI(IK1,3)
33012           IF(IN.GT.0) AMS=AMS+AMH(IN)
33013           IF (AMS.LT.AMSS) AMSS=AMS
33014    20   CONTINUE
33015         IF(UMOO.LT.AMSS) UMOO=AMSS
33016         THRESH(IK)=UMOO
33017    30 CONTINUE
33018       RETURN
33019       END
33020
33021 *$ CREATE DT_DCHANH.FOR
33022 *COPY DT_DCHANH
33023 *
33024 *===dchanh=============================================================*
33025 *
33026       SUBROUTINE DT_DCHANH
33027
33028       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33029       SAVE
33030
33031       PARAMETER ( LINP = 10 ,
33032      &            LOUT = 6 ,
33033      &            LDAT = 9 )
33034
33035 * particle properties (BAMJET index convention),
33036 * (dublicate of DTPART for HADRIN)
33037       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33038      &                K1H(110),K2H(110)
33039
33040       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33041
33042       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33043
33044       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33045      &                NRK(2,268),NURE(30,2)
33046
33047       DIMENSION HWT(460),HWK(40),SI(5184)
33048       EQUIVALENCE (WK(1),SI(1))
33049 C--------------------
33050 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
33051 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
33052 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
33053 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
33054 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
33055 C--------------------------
33056       IREG=16
33057       DO 90 IRE=1,IREG
33058         IWKO=IRII(IRE)
33059         IEE=IEII(IRE+1)-IEII(IRE)
33060         IKE=IKII(IRE+1)-IKII(IRE)
33061         IEO=IEII(IRE)+1
33062         IIKA=IKII(IRE)
33063 *   modifications to suppress elestic scattering  24/07/91
33064         DO 80 IE=1,IEE
33065           SIS=1.D-14
33066           SINORC=0.0D0
33067           DO 10 IK=1,IKE
33068             IWK=IWKO+IEE*(IK-1)+IE
33069             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33070             SIS=SIS+SI(IWK)*SINORC
33071    10     CONTINUE
33072           SIIN(IEO+IE-1)=SIS
33073           SIO=0.D0
33074           IF (SIS.GE.1.D-12)                                    GO TO 20
33075           SIS=1.D0
33076           SIO=1.D0
33077    20     CONTINUE
33078           SINORC=0.0D0
33079           DO 30 IK=1,IKE
33080             IWK=IWKO+IEE*(IK-1)+IE
33081             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33082             SIO=SIO+SI(IWK)*SINORC/SIS
33083             HWK(IK)=SIO
33084    30     CONTINUE
33085           DO 40 IK=1,IKE
33086             IWK=IWKO+IEE*(IK-1)+IE
33087    40     WK(IWK)=HWK(IK)
33088           IIKI=IKII(IRE)
33089           DO 70 IK=1,IKE
33090             AM111=0.D0
33091             INRK1=NRK(1,IIKI+IK)
33092             IF (INRK1.GT.0) AM111=AMH(INRK1)
33093             AM222=0.D0
33094             INRK2=NRK(2,IIKI+IK)
33095             IF (INRK2.GT.0) AM222=AMH(INRK2)
33096             THRESH(IIKI+IK)=AM111 +AM222
33097             IF (INRK2-1.GE.0)                                   GO TO 60
33098             INRKK=K1H(INRK1)
33099             AMSS=5.D0
33100             INRKO=K2H(INRK1)
33101             DO 50 INRK1=INRKK,INRKO
33102               INZK1=NZKI(INRK1,1)
33103               INZK2=NZKI(INRK1,2)
33104               INZK3=NZKI(INRK1,3)
33105               IF (INZK1.LE.0.OR.INZK1.GT.110)                   GO TO 50
33106               IF (INZK2.LE.0.OR.INZK2.GT.110)                   GO TO 50
33107               IF (INZK3.LE.0.OR.INZK3.GT.110)                   GO TO 50
33108 C     WRITE (6,310)INRK1,INZK1,INZK2,INZK3
33109  1000 FORMAT (4I10)
33110               AMS=AMH(INZK1)+AMH(INZK2)
33111               IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
33112               IF (AMSS.GT.AMS) AMSS=AMS
33113    50       CONTINUE
33114             AMS=AMSS
33115             IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
33116             THRESH(IIKI+IK)=AMS
33117    60       CONTINUE
33118    70     CONTINUE
33119    80   CONTINUE
33120    90 CONTINUE
33121       DO 100 J=1,460
33122   100 HWT(J)=0.D0
33123       DO 120 I=1,110
33124         IK1=K1H(I)
33125         IK2=K2H(I)
33126         HV=0.D0
33127         IF (IK2.GT.460)IK2=460
33128         IF (IK1.LE.0)IK1=1
33129         DO 110 J=IK1,IK2
33130           HV=HV+WTI(J)
33131           HWT(J)=HV
33132           JI=J
33133   110   CONTINUE
33134         IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
33135  1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
33136   120 CONTINUE
33137       DO 130 J=1,460
33138   130 WTI(J)=HWT(J)
33139       RETURN
33140       END
33141
33142 *$ CREATE DT_DHADDE.FOR
33143 *COPY DT_DHADDE
33144 *
33145 *===dhadde=============================================================*
33146 *
33147       SUBROUTINE DT_DHADDE
33148
33149       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33150       SAVE
33151
33152 * particle properties (BAMJET index convention)
33153       CHARACTER*8  ANAME
33154       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33155      &                IICH(210),IIBAR(210),K1(210),K2(210)
33156
33157 * HADRIN: decay channel information
33158       PARAMETER (IDMAX9=602)
33159       CHARACTER*8 ZKNAME
33160       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
33161
33162 * particle properties (BAMJET index convention),
33163 * (dublicate of DTPART for HADRIN)
33164       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33165      &                K1H(110),K2H(110)
33166
33167       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33168
33169 * decay channel information for HADRIN
33170       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33171      &                K1Z(16),K2Z(16),WTZ(153),II22,
33172      &                NZK1(153),NZK2(153),NZK3(153)
33173
33174       DATA IRETUR/0/
33175
33176       IRETUR=IRETUR+1
33177       AMH(31)=0.48D0
33178       IF (IRETUR.GT.1) RETURN
33179       DO 10 I=1,94
33180         AMH(I)   = AAM(I)
33181         GAH(I)   = GA(I)
33182         TAUH(I)  = TAU(I)
33183         ICHH(I)  = IICH(I)
33184         IBARH(I) = IIBAR(I)
33185         K1H(I)   = K1(I)
33186         K2H(I)   = K2(I)
33187    10 CONTINUE
33188 **sr
33189 C     AMH(1)=0.93828D0
33190       AMH(1)=0.9383D0
33191 **
33192       AMH(2)=AMH(1)
33193       DO 20 I=26,30
33194         K1H(I)=452
33195         K2H(I)=452
33196    20 CONTINUE
33197       DO 30 I=1,307
33198         WTI(I)    = WT(I)
33199         NZKI(I,1) = NZK(I,1)
33200         NZKI(I,2) = NZK(I,2)
33201         NZKI(I,3) = NZK(I,3)
33202    30 CONTINUE
33203       DO 40 I=1,16
33204         L=I+94
33205         AMH(L)=AMZ(I)
33206         GAH( L)=GAZ(I)
33207         TAUH( L)=TAUZ(I)
33208         ICHH( L)=ICHZ(I)
33209         IBARH( L)=IBARZ(I)
33210         K1H( L)=K1Z(I)
33211         K2H( L)=K2Z(I)
33212    40 CONTINUE
33213       DO 50 I=1,153
33214         L=I+307
33215         WTI(L)    = WTZ(I)
33216         NZKI(L,3) = NZK3(I)
33217         NZKI(L,2) = NZK2(I)
33218         NZKI(L,1) = NZK1(I)
33219    50 CONTINUE
33220       RETURN
33221       END
33222
33223 *$ CREATE IDT_IEFUND.FOR
33224 *COPY IDT_IEFUND
33225 *
33226 *===iefund=============================================================*
33227 *
33228       INTEGER FUNCTION IDT_IEFUND(PL,IRE)
33229
33230       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33231       SAVE
33232
33233 C*****IEFUN CALCULATES A MOMENTUM INDEX
33234
33235       PARAMETER ( LINP = 10 ,
33236      &            LOUT = 6 ,
33237      &            LDAT = 9 )
33238
33239       COMMON /HNDRUN/ RUNTES,EFTES
33240
33241       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33242
33243       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33244      &                NRK(2,268),NURE(30,2)
33245
33246       IPLA=IEII(IRE)+1
33247      *+1
33248       IPLE=IEII(IRE+1)
33249       IF (PL.LT.0.)                                             GO TO 30
33250       DO 10 I=IPLA,IPLE
33251         J=I-IPLA+1
33252         IF (PL.LE.PLABF(I))                                     GO TO 60
33253    10 CONTINUE
33254       I=IPLE
33255       IF ( EFTES.GT.40.D0)                                      GO TO 20
33256       EFTES=EFTES+1.0D0
33257       WRITE(LOUT,1000)PL,J
33258    20 CONTINUE
33259                                                                 GO TO 70
33260    30 CONTINUE
33261       DO 40 I=IPLA,IPLE
33262         J=I-IPLA+1
33263         IF (-PL.LE.UMO(I))                                      GO TO 60
33264    40 CONTINUE
33265       I=IPLE
33266       IF ( EFTES.GT.40.D0)                                      GO TO 50
33267       EFTES=EFTES+1.0D0
33268       WRITE(LOUT,1000)PL,I
33269    50 CONTINUE
33270    60 CONTINUE
33271    70 CONTINUE
33272       IDT_IEFUND=I
33273       RETURN
33274  1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
33275      +7H IEFUN=,I5)
33276       END
33277
33278 *$ CREATE DT_DSIGIN.FOR
33279 *COPY DT_DSIGIN
33280 *
33281 *===dsigin=============================================================*
33282 *
33283       SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
33284
33285       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33286       SAVE
33287
33288 * particle properties (BAMJET index convention),
33289 * (dublicate of DTPART for HADRIN)
33290       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33291      &                K1H(110),K2H(110)
33292
33293       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33294
33295       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33296      &                NRK(2,268),NURE(30,2)
33297
33298       IE=IDT_IEFUND(PLAB,IRE)
33299       IF (IE.LE.IEII(IRE)) IE=IE+1
33300       AMT=AMH(ITAR)
33301       AMN=AMH(N)
33302       AMN2=AMN*AMN
33303       AMT2=AMT*AMT
33304       ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
33305 C*** INTERPOLATION PREPARATION
33306       ECMO=UMO(IE)
33307       ECM1=UMO(IE-1)
33308       DECM=ECMO-ECM1
33309       DEC=ECMO-ECM
33310       IIKI=IKII(IRE)+1
33311       EKLIM=-THRESH(IIKI)
33312       WOK=SIIN(IE)
33313       WDK=WOK-SIIN(IE-1)
33314       IF (ECM.GT.ECMO) WDK=0.0D0
33315 C*** INTERPOLATION IN CHANNEL WEIGHTS
33316       IELIM=IDT_IEFUND(EKLIM,IRE)
33317       DELIM=UMO(IELIM)+EKLIM
33318      *+1.D-16
33319       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
33320       IF (DELIM*DELIM-DETE*DETE) 20,20,10
33321    10 DECC=DELIM
33322                                                                 GO TO 30
33323    20 DECC=DECM
33324    30 CONTINUE
33325       WKK=WOK-WDK*DEC/(DECC+1.D-9)
33326       IF (WKK.LT.0.0D0) WKK=0.0D0
33327       SI=WKK+1.D-12
33328       IF (-EKLIM.GT.ECM) SI=1.D-14
33329       RETURN
33330       END
33331
33332 *$ CREATE DT_DTCHOI.FOR
33333 *COPY DT_DTCHOI
33334 *
33335 *===dtchoi=============================================================*
33336 *
33337       SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
33338
33339       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33340       SAVE
33341
33342 C     ****************************
33343 C     TCHOIC CALCULATES A RANDOM VALUE
33344 C     FOR THE FOUR-MOMENTUM-TRANSFER T
33345 C     ****************************
33346
33347 * particle properties (BAMJET index convention),
33348 * (dublicate of DTPART for HADRIN)
33349       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33350      &                K1H(110),K2H(110)
33351
33352 * slope parameters for HADRIN interactions
33353       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
33354
33355       AMA=AM1
33356       AMB=AM2
33357       IF (I.GT.30.AND.II.GT.30)                                 GO TO 20
33358       III=II
33359       AM3=AM2
33360       IF (I.LE.30)                                              GO TO 10
33361       III=I
33362       AM3=AM1
33363    10 CONTINUE
33364                                                                 GO TO 30
33365    20 CONTINUE
33366       III=II
33367       AM3=AM2
33368       IF (AMA.LE.AMB)                                           GO TO 30
33369       III=I
33370       AM3=AM1
33371    30 CONTINUE
33372       IB=IBARH(III)
33373       AMA=AM3
33374       K=INT((AMA-0.75D0)/0.05D0)
33375       IF (K-2.LT.0) K=1
33376       IF (K-26.GE.0) K=25
33377       IF (IB)50,40,50
33378    40 BM=BBM(K)
33379                                                                 GO TO 60
33380    50 BM=BBB(K)
33381    60 CONTINUE
33382 C     NORMALIZATION
33383       TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1  **2
33384       TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1  **2
33385       VB=DT_RNDM(TMIN)
33386 **sr test
33387 C     IF (VB.LT.0.2D0) BM=BM*0.1
33388 C    **0.5
33389       BM = BM*5.05D0
33390 **
33391       TMI=BM*TMIN
33392       TMA=BM*TMAX
33393       ETMA=0.D0
33394       IF (ABS(TMA).GT.120.D0)                                   GO TO 70
33395       ETMA=EXP(TMA)
33396    70 CONTINUE
33397       AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
33398 C*** RANDOM CHOICE OF THE T - VALUE
33399       R=DT_RNDM(TMI)
33400       T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
33401       RETURN
33402       END
33403
33404 *$ CREATE DT_DTWOPA.FOR
33405 *COPY DT_DTWOPA
33406 *
33407 *===dtwopa=============================================================*
33408 *
33409       SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
33410      &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
33411
33412       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33413       SAVE
33414
33415 C     ******************************************************
33416 C     QUASI TWO PARTICLE PRODUCTION
33417 C     TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
33418 C     FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
33419 C     IN THE CM - SYSTEM
33420 C     COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
33421 C     SPHERICAL COORDINATES
33422 C     ******************************************************
33423
33424 * particle properties (BAMJET index convention),
33425 * (dublicate of DTPART for HADRIN)
33426       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33427      &                K1H(110),K2H(110)
33428
33429       AMA=AM1
33430       AMB=AM2
33431       AMA2=AMA*AMA
33432       E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
33433       E2=UMOO - E1
33434       IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
33435       AMTE=(E1-AMA)*(E1+AMA)
33436       AMTE=AMTE+1.D-18
33437       P1=SQRT(AMTE)
33438       P2=P1
33439 C     / P2 / = / P1 /  BUT OPPOSITE DIRECTIONS
33440 C     DETERMINATION  OF  THE ANGLES
33441 C     COS(THETA1)=COD1      COS(THETA2)=COD2
33442 C     SIN(PHI1)=SIF1        SIN(PHI2)=SIF2
33443 C     COS(PHI1)=COF1        COS(PHI2)=COF2
33444 C     PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
33445       CALL DT_DSFECF(COF1,SIF1)
33446       COF2=-COF1
33447       SIF2=-SIF1
33448 C     CALCULATION OF THETA1
33449       CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
33450       COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
33451       IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
33452       COD2=-COD1
33453       RETURN
33454       END
33455
33456 *$ CREATE DT_ZK.FOR
33457 *COPY DT_ZK
33458 *
33459 *===zk=================================================================*
33460 *
33461       BLOCK DATA DT_ZK
33462
33463       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33464       SAVE
33465
33466 * decay channel information for HADRIN
33467       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33468      &                K1Z(16),K2Z(16),WTZ(153),II22,
33469      &                NZK1(153),NZK2(153),NZK3(153)
33470
33471 * decay channel information for HADRIN
33472       CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
33473       COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
33474
33475 *     Particle masses in GeV                                           *
33476       DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
33477      &          2*1.7D0, 3*0.D0/
33478 *     Resonance width Gamma in GeV                                     *
33479       DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
33480 *     Mean life time in seconds                                        *
33481       DATA TAUZ / 16*0.D0 /
33482 *     Charge of particles and resonances                               *
33483       DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
33484 *     Baryonic charge                                                  *
33485       DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
33486 *     First number of decay channels used for resonances               *
33487 *     and decaying particles                                           *
33488       DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
33489      &          3*460/
33490 *     Last number of decay channels used for resonances                *
33491 *     and decaying particles                                           *
33492       DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
33493      &          3*460/
33494 *     Weight of decay channel                                          *
33495       DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
33496      & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
33497      & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
33498      & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
33499      & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
33500      & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
33501      & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
33502      & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
33503      & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
33504      & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
33505      & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
33506      & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
33507      & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
33508      & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
33509      & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
33510      & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
33511      & .05D0, .65D0, 9*1.D0 /
33512 *     Particle numbers in decay channel                                *
33513       DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
33514      & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
33515      & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
33516      & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
33517      & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
33518      & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
33519      & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
33520      & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
33521       DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
33522      & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
33523      & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
33524      & 4*33, 32, 3*35,  2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
33525      & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
33526      & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
33527      & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
33528      & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
33529      & 1, 8, 1, 8, 1, 9*0 /
33530       DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
33531      & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
33532      & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
33533      & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
33534      & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
33535      & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
33536 *     Particle  names                                                  *
33537       DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS  ',' PAP  ',' PAN  ',
33538      & 'APN', 'DEO   ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
33539      & 3*'BLANK' /
33540 *     Name of decay channel                                            *
33541       DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
33542      & 'ANNPI0','APPPI0','ANPPI-'/
33543       DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K-  ','K0AK0 ',
33544      & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET  ','&0R0  ','P-R+  ',
33545      & 'P+R-  ','POOM  ',' ETET ','ETSP0 ','R0ET  ',' R0R0 ','R+R-  ',
33546      & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
33547      & 'P+R-R0','R0OM  ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
33548      & 'P+R-OM','OMOM  ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
33549      & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
33550      & 'OMOMOM',
33551      & ' P+PO ','P+POPO','P+P+P-','P+ET  ','P0R+  ','P+R0  ','ETSP+ ',
33552      & 'R+ET  ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
33553      & 'P+R-R+','R+OM  ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
33554      & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
33555      & 'P-PO  ','P-POPO','P-P-P+','P-ET  ','POR-  ','P-R0  ','ETSP- ',
33556      & 'R-ET  ','R-R0  ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
33557       DATA ZKNAM6/'P+R-R-','R-OM  ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
33558      & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
33559      & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO  ','LPI+  ',
33560      & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
33561      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
33562      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
33563      & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
33564      & 9*'BLANK'/
33565 *=                                               end*block.zk      *
33566       END
33567
33568 *$ CREATE DT_BLKD43.FOR
33569 *COPY DT_BLKD43
33570 *
33571 *===blkd43=============================================================*
33572 *
33573       BLOCK DATA DT_BLKD43
33574
33575       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33576       SAVE
33577
33578 *
33579 *=== reac =============================================================*
33580 *
33581 *----------------------------------------------------------------------*
33582 *                                                                      *
33583 *     Created on 10 december 1991  by    Alfredo Ferrari & Paola Sala  *
33584 *                                                   Infn - Milan       *
33585 *                                                                      *
33586 *     Last change on 10-dec-91     by    Alfredo Ferrari               *
33587 *                                                                      *
33588 *     This is the original common reac of Hadrin                       *
33589 *                                                                      *
33590 *----------------------------------------------------------------------*
33591 *
33592
33593       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33594      &                NRK(2,268),NURE(30,2)
33595
33596       DIMENSION
33597      & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
33598      & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
33599      & SPIKP1(315), SPIKPU(278), SPIKPV(372),
33600      & SPIKPW(278), SPIKPX(372), SPIKP4(315),
33601      & SPIKP5(187), SPIKP6(289),
33602      & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
33603      & SPIKP9(143), SPIKP0(169), SPKPV(143),
33604      & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
33605      & SANPEL(84) , SPIKPF(273),
33606      & SPKP15(187), SPKP16(272),
33607      & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
33608      & NURELN(60)
33609 *
33610        DIMENSION NRKLIN(532)
33611        EQUIVALENCE (NRK(1,1), NRKLIN(1))
33612        EQUIVALENCE (   UMO(  1),  UMOPI(1)), (   UMO( 93),  UMOKC(1))
33613        EQUIVALENCE (   UMO(161),   UMOP(1)), (   UMO(200),   UMON(1))
33614        EQUIVALENCE (   UMO(263),  UMOK0(1))
33615        EQUIVALENCE ( PLABF(  1),  PLAPI(1)), ( PLABF( 93),  PLAKC(1))
33616        EQUIVALENCE ( PLABF(161),   PLAP(1)), ( PLABF(200),   PLAN(1))
33617        EQUIVALENCE ( PLABF(263),  PLAK0(1))
33618        EQUIVALENCE (   WK(   1), SPIKP1(1)), (   WK( 316), SPIKPU(1))
33619        EQUIVALENCE (   WK( 594), SPIKPV(1)), (   WK( 966), SPIKPW(1))
33620        EQUIVALENCE (   WK(1244), SPIKPX(1)), (   WK(1616), SPIKP4(1))
33621        EQUIVALENCE (   WK(1931), SPIKP5(1)), (   WK(2118), SPIKP6(1))
33622        EQUIVALENCE (   WK(2407), SKMPEL(1)), (   WK(2509), SPIKP7(1))
33623        EQUIVALENCE (   WK(2798), SKMNEL(1)), (   WK(2866), SPIKP8(1))
33624        EQUIVALENCE (   WK(3053), SPIKP9(1)), (   WK(3196), SPIKP0(1))
33625        EQUIVALENCE (   WK(3365),  SPKPV(1)), (   WK(3508), SAPPEL(1))
33626        EQUIVALENCE (   WK(3613), SPIKPE(1)), (   WK(4012), SAPNEL(1))
33627        EQUIVALENCE (   WK(4096), SPIKPZ(1)), (   WK(4369), SANPEL(1))
33628        EQUIVALENCE (   WK(4453), SPIKPF(1)), (   WK(4726), SPKP15(1))
33629        EQUIVALENCE (   WK(4913), SPKP16(1))
33630        EQUIVALENCE (NRK(1,1), NRKLIN(1))
33631        EQUIVALENCE (NRKLIN(   1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
33632        EQUIVALENCE (NRKLIN( 297),  NRKP(1)), (NRKLIN( 367),  NRKN(1))
33633        EQUIVALENCE (NRKLIN( 483), NRKK0(1))
33634        EQUIVALENCE (NURE(1,1), NURELN(1))
33635 *
33636 **** pi- p data                                                        *
33637 **** pi+ n data                                                        *
33638       DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
33639      & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
33640      & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
33641      & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
33642      & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
33643      & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
33644      & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
33645      & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
33646      & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
33647      & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
33648       DATA PLAKC /
33649      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33650      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33651      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33652      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33653      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33654      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33655      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33656      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33657      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33658      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33659      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33660      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33661       DATA PLAK0 /
33662      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33663      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33664      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33665      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33666      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33667      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33668 *                 pp   pn   np   nn                                    *
33669       DATA PLAP /
33670      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33671      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33672      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33673      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33674      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33675      & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
33676 *    app   apn   anp   ann                                             *
33677       DATA PLAN /
33678      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
33679      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33680      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33681      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
33682      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33683      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33684      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
33685      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33686      & 3.43D0, 3.75D0, 4.07D0, 4.43D0  /
33687       DATA SIIN / 296*0.D0 /
33688       DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33689      & 1.557D0,1.615D0,1.6435D0,
33690      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33691      & 2.286D0,2.366D0,2.482D0,2.56D0,
33692      & 2.735D0,2.90D0,
33693      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33694      & 1.496D0,1.527D0,1.557D0,
33695      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33696      & 2.071D0,2.159D0,2.286D0,2.366D0,
33697      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33698      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33699      & 1.496D0,1.527D0,1.557D0,
33700      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33701      & 2.071D0,2.159D0,2.286D0,2.366D0,
33702      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33703      &                   1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33704      & 1.557D0,1.615D0,1.6435D0,
33705      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33706      & 2.286D0,2.366D0,2.482D0,2.56D0,
33707      &  2.735D0, 2.90D0/
33708       DATA UMOKC/ 1.44D0,
33709      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33710      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33711      & 3.1D0,1.44D0,
33712      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33713      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33714      & 3.1D0,1.44D0,
33715      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33716      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33717      & 3.1D0,1.44D0,
33718      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33719      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33720      &  3.1D0/
33721       DATA UMOK0/ 1.44D0,
33722      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33723      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33724      & 3.1D0,1.44D0,
33725      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33726      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33727      &  3.1D0/
33728 *                 pp   pn   np   nn                                    *
33729       DATA UMOP/
33730      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33731      & 3.D0,3.1D0,3.2D0,
33732      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33733      & 3.D0,3.1D0,3.2D0,
33734      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33735      & 3.D0,3.1D0,3.2D0/
33736 *    app   apn   anp   ann                                             *
33737       DATA UMON /
33738      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33739      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33740      & 3.D0,3.1D0,3.2D0,
33741      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33742      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33743      & 3.D0,3.1D0,3.2D0,
33744      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33745      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33746      &  3.D0,3.1D0,3.2D0/
33747 **** reaction channel state particles                                  *
33748       DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
33749      & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
33750      & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
33751      & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
33752      & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
33753      & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
33754      & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
33755      & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
33756      & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
33757      & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
33758       DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
33759      & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
33760      & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
33761      & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
33762      & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
33763      & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
33764      & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
33765      & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
33766 *                                                                      *
33767 *   k0 p   k0 n   ak0 p   ak/ n                                        *
33768 *                                                                      *
33769       DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
33770      & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13,   22, 13, 21, 23,
33771      & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
33772      & 53, 47, 1, 103, 0, 93, 0/
33773 *   pp  pn   np   nn                                                   *
33774       DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
33775      & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
33776      & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
33777      & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
33778 *     app   apn   anp   ann                                            *
33779       DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
33780      & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
33781      & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
33782      & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
33783      & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
33784      & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
33785      & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
33786 **** channel cross section                                             *
33787       DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
33788      & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
33789      & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
33790      & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
33791      & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
33792      &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
33793      & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
33794      & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
33795      &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
33796      & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
33797      & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
33798      & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
33799      & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
33800      & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
33801      & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
33802      & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
33803      & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
33804      & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
33805      & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
33806      & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
33807 **** pi+ n data                                                        *
33808       DATA SPIKPU/   0.D0, 25.D0, 13.D0,  11.D0, 10.5D0, 14.D0,  20.D0,
33809      & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33810      & 10.D0, 10.D0, 9.5D0,  9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33811      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0,   5.5D0,  4.8D0,
33812      & 4.2D0, 7.5D0, 3.4D0,  2.5D0, 2.5D0, 2.1D0, 1.4D0,   1.D0,   .8D0,
33813      &  .6D0, .46D0,  .3D0, .2D0, .15D0, .13D0, 11*0.D0,  .95D0,  .65D0,
33814      & .48D0, .35D0,  .2D0, .18D0, .17D0, .16D0,  .15D0,   .1D0,  .09D0,
33815      & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0,  .2D0,   .1D0,
33816      & .08D0, .06D0, .045D0,   .03D0, .02D0, .01D0,      .005D0, .003D0,
33817      & 12*0.D0, .3D0, .24D0,   .18D0, .15D0, .13D0,  .12D0, .11D0, .1D0,
33818      & .09D0,  .08D0, .05D0,   .04D0, .03D0,  0.D0, 0.16D0, .7D0, 1.3D0,
33819      & 3.1D0,  4.5D0,  2.D0, 18*0.D0, 3*.0D0,  0.D0, 0.D0, 4.0D0, 11.D0,
33820      & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0,  1.5D0, .9D0, .55D0,
33821      &  .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0,   2.25D0, 3.3D0,
33822      & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
33823      & .64D0,  1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0,  4.4D0,   3.D0, 1.8D0,
33824      &  .9D0, .53D0, .28D0,      10*0.D0, 2*0.D0,  .25D0,  .82D0,
33825      & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0,  5.7D0, 3.9D0, 2.35D0, 1.15D0,
33826      & .69D0, .37D0, 10*0.D0,     7*0.D0,   .0D0, .34D0,  1.5D0, 3.47D0,
33827      & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0,  .3D0,  .15D0, 6*0.D0/
33828 *
33829       DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33830      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
33831      & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
33832      & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
33833      & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
33834      & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
33835      & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
33836      & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
33837      & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
33838      & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
33839      & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
33840      & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
33841      & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
33842      & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
33843      & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
33844      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33845      & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
33846      & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
33847      & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
33848      & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
33849 **** pi- p data                                                        *
33850       DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
33851      & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33852      & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33853      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33854      & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
33855      & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
33856      & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
33857      & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
33858      & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
33859      & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
33860      & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
33861      & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
33862      & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
33863      & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
33864      & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
33865      & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
33866      & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
33867      & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
33868      & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33869 *
33870       DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33871      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
33872      & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
33873      & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
33874      & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
33875      & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
33876      & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
33877      & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
33878      & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
33879      & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
33880      & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
33881      & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
33882      & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
33883      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33884      & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
33885      & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
33886      & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
33887      & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
33888      & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
33889      & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
33890 **** pi- n data                                                        *
33891       DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
33892      & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
33893      & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
33894      & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
33895      & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
33896      & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
33897      & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
33898      & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
33899      & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
33900      & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
33901      & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
33902      & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
33903      & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
33904      & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
33905      & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
33906      & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
33907      & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
33908      & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
33909      & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
33910      & 3.3D0, 5.4D0, 7.D0 /
33911 **** k+  p data                                                        *
33912       DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
33913      & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
33914      & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
33915      & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
33916      & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33917      & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
33918      & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
33919      & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
33920      & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
33921      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33922      & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
33923      & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
33924      & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
33925 **** k+  n data                                                        *
33926       DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
33927      & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
33928      & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
33929      & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
33930      & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33931      & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
33932      & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
33933      & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
33934      & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
33935      & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
33936      & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
33937      & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
33938      & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
33939      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33940      & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
33941      & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
33942      & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
33943      & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
33944      & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
33945 **** k-  p data                                                        *
33946       DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
33947      &     7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
33948      &    0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
33949      &    .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
33950      &    0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
33951      &    .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
33952      &    0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
33953      &    .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
33954      &    0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
33955      &    .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
33956      &    0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
33957      &    .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
33958       DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
33959      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
33960      & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
33961      & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
33962      & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,  3*0.D0, 1.0D0, 3.03D0,
33963      & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
33964      & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
33965      & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
33966      & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
33967      & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
33968      & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
33969      & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
33970      & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
33971      & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
33972      & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
33973      & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
33974      & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
33975      & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
33976      & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
33977      & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
33978      & 10*0.D0/
33979 ***** k- n data                                                        *
33980       DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
33981      &        3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
33982      &        0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
33983      &        1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
33984      &        0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
33985      &        .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
33986      &        0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
33987      &       .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
33988       DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
33989      &  14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
33990      &  1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
33991      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
33992      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
33993      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
33994      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
33995      &  7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
33996      &  .39D0, .22D0, .07D0, 0.D0,
33997      &  6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
33998      &  4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
33999      &  10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
34000      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34001      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34002      &  9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
34003      &  5.10D0, 5.44D0, 5.3D0,
34004      &  4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
34005 *****  p p data                                                        *
34006       DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34007      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34008      &              0.D0, 3.6D0, 1.7D0, 10*0.D0,
34009      &              .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
34010      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34011      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34012      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34013      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34014      &              16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
34015      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
34016      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
34017      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34018      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34019      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34020      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34021 *****  p n data                                                        *
34022       DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34023      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34024      &              0.D0, 1.8D0, .2D0,  12*0.D0,
34025      &              3.2D0, 6.05D0, 9.9D0, 5.1D0,
34026      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34027      &              2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34028      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34029      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34030      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34031      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34032      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34033      &              10*0.D0, .7D0, 5.1D0, 8.D0,
34034      &              10*0.D0, .7D0, 5.1D0, 8.D0,
34035      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
34036      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
34037      &              7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
34038      &              7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
34039      &              5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
34040 *   nn - data                                                          *
34041 *                                                                      *
34042       DATA SPKPV/  0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34043      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34044      &              0.D0, 3.6D0, 1.7D0, 12*0.D0,
34045      &              8.7D0, 17.7D0, 18.8D0, 15.9D0,
34046      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34047      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34048      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34049      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
34050      &              11.D0, 5.5D0, 3.5D0,
34051      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
34052      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
34053      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34054      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34055      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34056      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34057 ****************   ap - p - data                                       *
34058       DATA SAPPEL/ 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34059      &  50.D0,  50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34060      &  25.D0,  22.D0, 21.D0, 20.D0, 18.D0, 17.D0,  11*0.D0,
34061      &  .05D0,  .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34062      &  0.D0,  1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34063      &  .1D0,  .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34064      &  0.D0,  55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
34065      &  10.D0,  7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
34066      &  1.55D0,  1.3D0, .95D0, .75D0,
34067      &  0.D0,  3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34068      &  .25D0,  .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34069      & .01D0,  .008D0, .006D0, .005D0/
34070       DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34071      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34072      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
34073      & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
34074      & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
34075      & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
34076      & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
34077      & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
34078      & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
34079      & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
34080      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34081      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34082      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34083      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
34084      & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
34085      & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
34086      & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
34087      & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
34088      & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
34089      & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
34090 ****************   ap - n - data                                       *
34091       DATA SAPNEL/
34092      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0,  68.D0, 65.D0,
34093      & 50.D0, 50.D0,  43.D0,  42.D0,  40.5D0, 35.D0, 30.D0,  28.D0,
34094      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0,  17.D0, 11*0.D0,
34095      & .05D0, .15D0, .18D0,  .2D0,    .2D0,  .3D0,  .4D0,   .6D0,  .7D0,
34096      & .85D0,  0.D0,  1.D0,  .9D0,    .46D0, .3D0,  .23D0, .18D0, .16D0,
34097      & .14D0,  .1D0, .08D0, .05D0,    .02D0, .015D0, 4*.011D0, 3*.005D0,
34098      & 0.D0,  3.3D0,  3.D0, 1.5D0,     1.D0, .7D0,  .4D0,  .35D0, .4D0,
34099      & .25D0, .18D0, .08D0, .04D0,    .03D0, .023D0, .016D0, .014D0,
34100      & .01D0, .008D0, .006D0, .005D0 /
34101        DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34102      &  84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34103      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34104      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34105      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34106      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34107      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34108      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34109      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34110      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34111      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34112      & 4.9D0, 8.5D0,  15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34113      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34114      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34115 *                                                                      *
34116 *                                                                      *
34117 ****************   an - p - data                                       *
34118 *                                                                      *
34119       DATA SANPEL/
34120      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
34121      & 50.D0, 43.D0,  42.D0,  40.5D0, 35.D0, 30.D0, 28.D0,
34122      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0, 17.D0, 11*0.D0, .05D0,
34123      & .15D0, .18D0,   .2D0,   .2D0,   .3D0,  .4D0, .6D0,   .7D0, .85D0,
34124      & 0.D0,   1.D0,   .9D0,  .46D0,  .3D0,  .23D0, .18D0, .16D0, .14D0,
34125      & .1D0,  .08D0,  .05D0,  .02D0, .015D0, 4*.011D0, 3*.005D0,
34126      & 0.D0,  3.3D0,  3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
34127      & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34128      & .01D0, .008D0, .006D0, .005D0 /
34129       DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34130      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34131      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34132      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34133      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34134      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34135      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34136      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34137      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34138      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34139      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34140      & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34141      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34142      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34143 ****  ko - n - data                                                    *
34144       DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
34145      &      6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
34146      &      0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
34147      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34148      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34149      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34150      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34151      &    4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
34152      &     1.4D0, 1.2D0, 1.05D0, .9D0, .66D0,  .5D0,
34153      &    7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
34154      &   11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
34155      &    4.85D0, 4.9D0,
34156      &   10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
34157      &    6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
34158      &    2.85D0, 2.35D0, 2.01D0, 1.8D0,
34159      &   12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
34160      &   12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0  /
34161 **** ako - p - data                                                    *
34162       DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
34163      & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
34164      & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
34165      & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
34166      & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
34167      & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
34168      & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
34169      & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34170      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
34171      & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
34172      & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
34173      & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
34174      & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
34175      & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
34176      & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
34177      & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
34178      & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
34179      & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
34180      & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
34181      & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
34182      & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
34183       DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
34184      & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
34185 *=                                               end*block.blkdt3      *
34186       END
34187 *$ CREATE DT_QEL_POL.FOR
34188 *COPY DT_QEL_POL
34189 *
34190 *===qel_pol============================================================*
34191 *
34192       SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
34193
34194       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34195       SAVE
34196
34197       CALL DT_MASS_INI
34198       CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34199
34200       RETURN
34201       END
34202
34203 *$ CREATE DT_GEN_QEL.FOR
34204 *COPY DT_GEN_QEL
34205 C==================================================================
34206 C   Generation of  a Quasi-Elastic neutrino scattering
34207 C==================================================================
34208 *
34209 *===gen_qel============================================================*
34210 *
34211       SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34212
34213 C...Generate a quasi-elastic   neutrino/antineutrino
34214 C.  Interaction on a nuclear target
34215 C.  INPUT  : LTYP = neutrino type (1,...,6)
34216 C.           ENU (GeV) = neutrino energy
34217 C----------------------------------------------------
34218
34219       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34220       SAVE
34221
34222       PARAMETER ( LINP = 10 ,
34223      &            LOUT = 6 ,
34224      &            LDAT = 9 )
34225       PARAMETER (MAXLND=4000)
34226       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34227
34228 * nuclear potential
34229       LOGICAL LFERMI
34230       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
34231      &                EBINDP(2),EBINDN(2),EPOT(2,210),
34232      &                ETACOU(2),ICOUL,LFERMI
34233
34234 * steering flags for qel neutrino scattering modules
34235       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34236 **sr - removed (not needed)
34237 C     COMMON /CBAD/  LBAD, NBAD
34238 C     COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
34239 **
34240
34241       DIMENSION PI(3),PO(3)
34242 CJR+
34243       DATA ININU/0/
34244 CJR-
34245 C     REAL*8 DBETA(3)
34246 C     REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
34247       DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
34248       DATA AMN  /0.93827231D0, 0.93956563D0/
34249       DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
34250       DATA INIPRI/0/
34251
34252 C     DATA PFERMI/0.22D0/
34253 CGB+...Binding Energy
34254       DATA EBIND/0.008D0/
34255 CGB-...
34256
34257       ININU=ININU+1
34258       IF(ININU.EQ.1)NDSIG=0
34259       LBAD = 0
34260       enu0=enu
34261 c      write(*,*) enu0
34262 C...Lepton mass
34263       AML = AML0(LTYP)       !  massa leptoni
34264       AML2 = AML**2          !  massa leptoni **2
34265 C...Particle labels (LUND)
34266       N = 5
34267       K(1,1) = 21
34268       K(2,1) = 21
34269       K(3,1) = 21
34270       K(3,3) = 1
34271       K(4,1) = 1
34272       K(4,3) = 1
34273       K(5,1) = 1
34274       K(5,3) = 2
34275       K0 = (LTYP-1)/2          !  2
34276       K1 = LTYP/2              !  2
34277       KA = 12 + 2*K0           !  16
34278       IS = -1 + 2*LTYP - 4*K1  !  -1 +10 -8 = 1
34279       K(1,2) = IS*KA
34280       K(4,2) = IS*(KA-1)
34281       K(3,2) = IS*24
34282       LNU = 2 - LTYP + 2*K1    !  2 - 5 + 2 = - 1
34283       IF (LNU .EQ. 2)  THEN
34284         K(2,2) = 2212
34285         K(5,2) = 2112
34286         AMI = AMN(1)
34287         AMF = AMN(2)
34288 CJR+
34289         PFERMI=PFERMN(2)
34290 CJR-
34291       ELSE
34292         K(2,2) = 2112
34293         K(5,2) = 2212
34294         AMI = AMN(2)
34295         AMF = AMN(1)
34296 CJR+
34297         PFERMI=PFERMP(2)
34298 CJR-
34299       ENDIF
34300       AMI2 = AMI**2
34301       AMF2 = AMF**2
34302
34303       DO IGB=1,5
34304         P(3,IGB) = 0.
34305         P(4,IGB) = 0.
34306         P(5,IGB) = 0.
34307       END DO
34308
34309       NTRY = 0
34310 CGB+...
34311       EFMAX  = SQRT(PFERMI**2 + AMI2) -AMI             ! max. Fermi Energy
34312       ENWELL = EFMAX + EBIND ! depth of nuclear potential well
34313 CGB-...
34314
34315   100 CONTINUE
34316
34317 C...4-momentum initial lepton
34318       P(1,5) = 0.     ! massa
34319       P(1,4) = ENU0    ! energia
34320       P(1,1) = 0.     ! px
34321       P(1,2) = 0.     ! py
34322       P(1,3) = ENU0    ! pz
34323
34324 C     PF = PFERMI*PYR(0)**(1./3.)
34325 c       write(23,*) PYR(0)
34326 c      write(*,*) 'Pfermi=',PF
34327 c      PF = 0.
34328       NTRY=NTRY+1
34329 C     IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
34330       IF (NTRY .GT. 500)  THEN
34331         LBAD = 1
34332         WRITE (LOUT,1001)  NBAD, ENU
34333         RETURN
34334       ENDIF
34335 C     CT = -1. + 2.*PYR(0)
34336 c      CT = -1.
34337 C     ST =  SQRT(1.-CT*CT)
34338 C     F = 2.*3.1415926*PYR(0)
34339 c      F = 0.
34340
34341 C     P(2,4) = SQRT(PF*PF + MI2) - EBIND  ! energia
34342 C     P(2,1) = PF*ST*COS(F)               ! px
34343 C     P(2,2) = PF*ST*SIN(F)               ! py
34344 C     P(2,3) = PF*CT                      ! pz
34345 C     P(2,5) = SQRT(P(2,4)**2-PF*PF)      ! massa
34346        P(2,1) = P21
34347        P(2,2) = P22
34348        P(2,3) = P23
34349        P(2,4) = P24
34350        P(2,5) = P25
34351       beta1=-p(2,1)/p(2,4)
34352       beta2=-p(2,2)/p(2,4)
34353       beta3=-p(2,3)/p(2,4)
34354       N=2
34355 C      WRITE(6,*)' before transforming into target rest frame'
34356
34357       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
34358
34359 C      print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
34360       N=5
34361
34362       phi11=atan(p(1,2)/p(1,3))
34363       pi(1)=p(1,1)
34364       pi(2)=p(1,2)
34365       pi(3)=p(1,3)
34366
34367       CALL DT_TESTROT(PI,Po,PHI11,1)
34368       DO ll=1,3
34369         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34370       END DO
34371 c        WRITE(*,*) po
34372       p(1,1)=po(1)
34373       p(1,2)=po(2)
34374       p(1,3)=po(3)
34375       phi12=atan(p(1,1)/p(1,3))
34376
34377       pi(1)=p(1,1)
34378       pi(2)=p(1,2)
34379       pi(3)=p(1,3)
34380       CALL DT_TESTROT(Pi,Po,PHI12,2)
34381       DO ll=1,3
34382         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34383       END DO
34384 c        WRITE(*,*) po
34385       p(1,1)=po(1)
34386       p(1,2)=po(2)
34387       p(1,3)=po(3)
34388
34389       enu=p(1,4)
34390
34391 C...Kinematical limits in Q**2
34392 c      S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) !            ????
34393       S = P(2,5)**2 + 2.*ENU*P(2,5)
34394       SQS = SQRT(S)                          ! E centro massa
34395       IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
34396       ELF = (S-AMF2+AML2)/(2.*SQS)           ! energia leptone finale p
34397       PSTAR = (S-P(2,5)**2)/(2.*SQS)       ! p* neutrino nel c.m.
34398       PLF = SQRT(ELF**2-AML2)               ! 3-momento leptone finale
34399       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)    ! + o -
34400       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)    ! according con cos(theta)
34401       IF (Q2MIN .LT. 0.)   Q2MIN = 0.      ! ??? non fisico
34402
34403 C...Generate Q**2
34404       DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
34405   200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
34406       DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
34407       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
34408       CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
34409       NDSIG=NDSIG+1
34410 C     WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
34411 C    &Q2,Q2min,Q2MAX,DSIGEV
34412
34413 C...c.m. frame. Neutrino along z axis
34414       DETOT = (P(1,4)) + (P(2,4)) ! e totale
34415       DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
34416       DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
34417       DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
34418 c      WRITE(*,*)
34419 c      WRITE(*,*)
34420 C      WRITE(*,*) 'Input values laboratory frame'
34421       N=2
34422
34423       CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
34424
34425       N=5
34426 c      STHETA = ULANGL(P(1,3),P(1,1))
34427 c      write(*,*) 'stheta' ,stheta
34428 c      stheta=0.
34429 c      CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
34430 c      WRITE(*,*)
34431 c      WRITE(*,*)
34432 C      WRITE(*,*) 'Output values cm frame'
34433 C...Kinematic in c.m. frame
34434       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
34435       STSTAR = SQRT(1.-CTSTAR**2)
34436       PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
34437       P(4,5) = AML                  ! massa leptone
34438       P(4,4) = ELF                 ! e leptone
34439       P(4,3) = PLF*CTSTAR          ! px
34440       P(4,1) = PLF*STSTAR*COS(PHI) ! py
34441       P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
34442
34443       P(5,5) = AMF                  ! barione
34444       P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
34445       P(5,3) = -P(4,3)             ! px
34446       P(5,1) = -P(4,1)             ! py
34447       P(5,2) = -P(4,2)             ! pz
34448
34449       P(3,5) = -Q2
34450       P(3,1) = P(1,1)-P(4,1)
34451       P(3,2) = P(1,2)-P(4,2)
34452       P(3,3) = P(1,3)-P(4,3)
34453       P(3,4) = P(1,4)-P(4,4)
34454
34455 C...Transform back to laboratory  frame
34456 C      WRITE(*,*) 'before going back to nucl rest frame'
34457 c      CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
34458       N=5
34459
34460       CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
34461
34462 C      WRITE(*,*) 'Now back in nucl rest frame'
34463       IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
34464
34465 c********************************************
34466
34467       DO kw=1,5
34468         pi(1)=p(kw,1)
34469         pi(2)=p(kw,2)
34470         pi(3)=p(kw,3)
34471         CALL DT_TESTROT(Pi,Po,PHI12,3)
34472         DO ll=1,3
34473           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34474         END DO
34475         p(kw,1)=po(1)
34476         p(kw,2)=po(2)
34477         p(kw,3)=po(3)
34478       END DO
34479 c********************************************
34480
34481       DO kw=1,5
34482         pi(1)=p(kw,1)
34483         pi(2)=p(kw,2)
34484         pi(3)=p(kw,3)
34485         CALL DT_TESTROT(Pi,Po,PHI11,4)
34486         DO ll=1,3
34487           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34488         END DO
34489         p(kw,1)=po(1)
34490         p(kw,2)=po(2)
34491         p(kw,3)=po(3)
34492       END DO
34493
34494 c********************************************
34495
34496 C      WRITE(*,*) 'Now back in lab frame'
34497
34498       CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
34499
34500 CGB+...
34501 C...test (on final momentum of nucleon) if Fermi-blocking
34502 C...is operating
34503       ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
34504      &  - P(5,5)
34505       IF (ENUCL.LT. EFMAX) THEN
34506         IF(INIPRI.LT.10)THEN
34507           INIPRI=INIPRI+1
34508 C         WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
34509 C...the interaction is not possible due to Pauli-Blocking and
34510 C...it must be resampled
34511         ENDIF
34512         GOTO 100
34513       ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
34514         IF(INIPRI.LT.10)THEN
34515           INIPRI=INIPRI+1
34516 C     WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
34517         ENDIF
34518 C                      Reject (J:R) here all these events
34519 C                      are otherwise rejected in dpmjet
34520         GOTO 100
34521 C...the interaction is possible, but the nucleon remains inside
34522 C...the nucleus. The nucleus is therefore left excited.
34523 C...We treat this case as a nucleon with 0 kinetic energy.
34524 C       P(5,5) = AMF
34525 C       P(5,4) = AMF
34526 C       P(5,1) = 0.
34527 C       P(5,2) = 0.
34528 C       P(5,3) = 0.
34529       ELSE IF (ENUCL.GE.ENWELL) THEN
34530 C     WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
34531 C...the interaction is possible, the nucleon can exit the nucleus
34532 C...but the nuclear well depth must be subtracted. The nucleus could be
34533 C...left in an excited state.
34534         Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
34535 C       P(5,4) = ENUCL-ENWELL + AMF
34536         Pnucl = SQRT(P(5,4)**2-AMF**2)
34537 C...The 3-momentum is scaled assuming that the direction remains
34538 C...unaffected
34539         P(5,1) = P(5,1) * Pnucl/Pstart
34540         P(5,2) = P(5,2) * Pnucl/Pstart
34541         P(5,3) = P(5,3) * Pnucl/Pstart
34542 C     WRITE(6,*)' qel new P(5,4) ',P(5,4)
34543       ENDIF
34544 CGB-...
34545       DSIGSU=DSIGSU+DSIGEV
34546
34547          GA=P(4,4)/P(4,5)
34548          BGX=P(4,1)/P(4,5)
34549          BGY=P(4,2)/P(4,5)
34550          BGZ=P(4,3)/P(4,5)
34551 *
34552          DBETB(1)=BGX/GA
34553          DBETB(2)=BGY/GA
34554          DBETB(3)=BGZ/GA
34555          IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
34556
34557             CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
34558
34559          ENDIF
34560 c
34561 C      PRINT*,' FINE   EVENTO '
34562       enu=enu0
34563       RETURN
34564
34565  1001 FORMAT(2X, 'DT_GEN_QEL   : event rejected ', I5,  G10.3)
34566       END
34567
34568 *$ CREATE DT_MASS_INI.FOR
34569 *COPY DT_MASS_INI
34570 C====================================================================
34571 C.  Masses
34572 C====================================================================
34573 *
34574 *===mass_ini===========================================================*
34575 *
34576       SUBROUTINE DT_MASS_INI
34577 C...Initialize  the kinematics for the quasi-elastic cross section
34578
34579       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34580       SAVE
34581
34582 * particle masses used in qel neutrino scattering modules
34583       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34584      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34585      &                EMPROTSQ,EMNEUTSQ,EMNSQ
34586
34587       EML(1) = 0.51100D-03   ! e-
34588       EML(2) = EML(1)        ! e+
34589       EML(3) = 0.105659D0      ! mu-
34590       EML(4) = EML(3)        ! mu+
34591       EML(5) = 1.7777D0        ! tau-
34592       EML(6) = EML(5)        ! tau+
34593       EMPROT = 0.93827231D0    ! p
34594       EMNEUT = 0.93956563D0    ! n
34595       EMPROTSQ = EMPROT**2
34596       EMNEUTSQ = EMNEUT**2
34597       EMN = (EMPROT + EMNEUT)/2.
34598       EMNSQ = EMN**2
34599       DO J=1,3
34600         J0 = 2*(J-1)
34601         EMN1(J0+1) = EMNEUT
34602         EMN1(J0+2) = EMPROT
34603         EMN2(J0+1) = EMPROT
34604         EMN2(J0+2) = EMNEUT
34605       ENDDO
34606       DO J=1,6
34607         EMLSQ(J) = EML(J)**2
34608         ETQE(J)  = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
34609       ENDDO
34610       RETURN
34611       END
34612
34613 *$ CREATE DT_DSQEL_Q2.FOR
34614 *COPY DT_DSQEL_Q2
34615 *
34616 *===dsqel_q2===========================================================*
34617 *
34618       DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
34619
34620 C...differential cross section for  Quasi-Elastic scattering
34621 C.       nu + N -> l + N'
34622 C.  From Llewellin Smith  Phys.Rep.  3C, 261, (1971).
34623 C.
34624 C.  INPUT :  JTYP = 1,...,6    nu_e, ...., nubar_tau
34625 C.           ENU (GeV) =  Neutrino energy
34626 C.           Q2  (GeV**2) =  (Transfer momentum)**2
34627 C.
34628 C.  OUTPUT : DSQEL_Q2  = differential  cross section :
34629 C.                       dsigma/dq**2  (10**-38 cm+2/GeV**2)
34630 C------------------------------------------------------------------
34631
34632       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34633       SAVE
34634
34635 * particle masses used in qel neutrino scattering modules
34636       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34637      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34638      &                EMPROTSQ,EMNEUTSQ,EMNSQ
34639 **sr - removed (not needed)
34640 C     COMMON /CAXIAL/ FA0, AXIAL2
34641 **
34642
34643       DIMENSION SS(6)
34644       DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34645       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34646       DATA AXIAL2 /1.03D0/  ! to be checked
34647
34648       FA0=-1.253D0
34649       CSI = 3.71D0                   !  ???
34650       GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2   ! G_e(q**2)
34651       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
34652       X = Q2/(EMN*EMN)     ! emn=massa barione
34653       XA = X/4.D0
34654       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34655       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34656       FA = FA0/(1.D0 + Q2/AXIAL2)**2
34657       FFA = FA*FA
34658       FFV1 = FV1*FV1
34659       FFV2 = FV2*FV2
34660       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
34661       A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
34662       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
34663       AA = (XA+0.25D0*RM)*(A1 + A2)
34664       BB = -X*FA*(FV1 + FV2)
34665       CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
34666       SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34667       DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU)  !
34668       IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
34669
34670       RETURN
34671       END
34672
34673 *$ CREATE DT_PREPOLA.FOR
34674 *COPY DT_PREPOLA
34675 *
34676 *===prepola============================================================*
34677 *
34678       SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
34679
34680       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34681       SAVE
34682 c
34683 c By G. Battistoni and E. Scapparone (sept. 1997)
34684 c According to:
34685 c     Albright & Jarlskog, Nucl Phys B84 (1975) 467
34686 c
34687 c
34688       PARAMETER (MAXLND=4000)
34689       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34690
34691       COMMON /QNPOL/ POLARX(4),PMODUL
34692
34693 * particle masses used in qel neutrino scattering modules
34694       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34695      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34696      &                EMPROTSQ,EMNEUTSQ,EMNSQ
34697
34698 * steering flags for qel neutrino scattering modules
34699       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34700 **sr - removed (not needed)
34701 C     COMMON /CAXIAL/ FA0, AXIAL2
34702 C     COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
34703 C    &        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
34704 **
34705       REAL*8 POL(4,4),BB2(3)
34706       DIMENSION SS(6)
34707 C     DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34708       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34709 **sr uncommented since common block CAXIAL is now commented
34710       DATA AXIAL2 /1.03D0/  ! to be checked
34711 **
34712
34713       RML=P(4,5)
34714       RMM=0.93960D+00
34715       FM2 = RMM**2
34716       MPI = 0.135D+00
34717       OLDQ2=Q2
34718       FA0=-1.253D+00
34719       CSI = 3.71D+00                      !
34720       GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2   ! G_e(q**2)
34721       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
34722       X = Q2/(EMN*EMN)     ! emn=massa barione
34723       XA = X/4.D0
34724       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34725       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34726       FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
34727       FFA = FA*FA
34728       FFV1 = FV1*FV1
34729       FFV2 = FV2*FV2
34730       FP=2.D0*FA*RMM/(MPI**2 + Q2)
34731       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
34732       A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
34733       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
34734       AA = (XA+0.25D+00*RM)*(A1 + A2)
34735       BB = -X*FA*(FV1 + FV2)
34736       CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
34737       SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34738
34739       OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2   )  ! articolo di ll...-smith
34740       OMEGA2=4.D+00*CC
34741       OMEGA3=2.D+00*FA*(FV1+FV2)
34742       OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
34743      1     (Q2/FM2))*FP**2)
34744       OMEGA5=OMEGA2
34745       OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
34746       WW1=2.D+00*OMEGA1*EMN**2
34747       WW2=2.D+00*OMEGA2*EMN**2
34748       WW3=2.D+00*OMEGA3*EMN**2
34749       WW4=2.D+00*OMEGA4*EMN**2
34750       WW5=2.D+00*OMEGA5*EMN**2
34751
34752       DO I=1,3
34753         BB2(I)=-P(4,I)/P(4,4)
34754       END DO
34755 c      WRITE(*,*)
34756 c      WRITE(*,*)
34757 c      WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
34758       N=5
34759
34760       CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
34761
34762 * NOW PARTICLES ARE IN THE SCATTERED LEPTON  REST FRAME
34763 c      WRITE(*,*)
34764 c      WRITE(*,*)
34765 c      WRITE(*,*) 'Prepola: now in lepton rest frame'
34766       EE=ENU
34767       QM2=Q2+RML**2
34768       U=Q2/(2.*RMM)
34769       FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
34770      +     (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
34771      +     ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
34772
34773       FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
34774      +     - ((RML**2)/FM2)*WW4                        !<=FM2 inv di RMM!!
34775
34776       FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
34777
34778       DO I=1,3
34779         POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
34780         POLARX(I)=POL(4,I)
34781       END DO
34782
34783       PMODUL=0.D0
34784       DO I=1,3
34785         PMODUL=PMODUL+POL(4,I)**2
34786       END DO
34787
34788       IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
34789          IF(NEUDEC.EQ.1) THEN
34790             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
34791      +        ETL,PXL,PYL,PZL,
34792      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34793 c
34794 c     Tau has decayed in muon
34795 c
34796          ENDIF
34797          IF(NEUDEC.EQ.2) THEN
34798             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
34799      +        ETL,PXL,PYL,PZL,
34800      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34801 c
34802 c     Tau has decayed in electron
34803 c
34804          ENDIF
34805          K(4,1)=15
34806          K(4,4) = 6
34807          K(4,5) = 8
34808          N=N+3
34809 c
34810 c     fill common for muon(electron)
34811 c
34812          P(6,1)=PXL
34813          P(6,2)=PYL
34814          P(6,3)=PZL
34815          P(6,4)=ETL
34816          K(6,1)=1
34817          IF(JTYP.EQ.5) THEN
34818             IF(NEUDEC.EQ.1) THEN
34819                P(6,5)=EML(JTYP-2)
34820                K(6,2)=13
34821             ELSEIF(NEUDEC.EQ.2) THEN
34822                P(6,5)=EML(JTYP-4)
34823                K(6,2)=11
34824             ENDIF
34825          ELSEIF(JTYP.EQ.6) THEN
34826             IF(NEUDEC.EQ.1) THEN
34827                K(6,2)=-13
34828             ELSEIF(NEUDEC.EQ.2) THEN
34829                K(6,2)=-11
34830             ENDIF
34831          END IF
34832          K(6,3)=4
34833          K(6,4)=0
34834          K(6,5)=0
34835 c
34836 c     fill common for tau_(anti)neutrino
34837 c
34838          P(7,1)=PXB
34839          P(7,2)=PYB
34840          P(7,3)=PZB
34841          P(7,4)=ETB
34842          P(7,5)=0.
34843          K(7,1)=1
34844          IF(JTYP.EQ.5) THEN
34845             K(7,2)=16
34846          ELSEIF(JTYP.EQ.6) THEN
34847             K(7,2)=-16
34848          END IF
34849          K(7,3)=4
34850          K(7,4)=0
34851          K(7,5)=0
34852 c
34853 c     Fill common for muon(electron)_(anti)neutrino
34854 c
34855          P(8,1)=PXN
34856          P(8,2)=PYN
34857          P(8,3)=PZN
34858          P(8,4)=ETN
34859          P(8,5)=0.
34860          K(8,1)=1
34861          IF(JTYP.EQ.5) THEN
34862             IF(NEUDEC.EQ.1) THEN
34863                K(8,2)=-14
34864             ELSEIF(NEUDEC.EQ.2) THEN
34865                K(8,2)=-12
34866             ENDIF
34867          ELSEIF(JTYP.EQ.6) THEN
34868             IF(NEUDEC.EQ.1) THEN
34869                K(8,2)=14
34870             ELSEIF(NEUDEC.EQ.2) THEN
34871                K(8,2)=12
34872             ENDIF
34873          END IF
34874          K(8,3)=4
34875          K(8,4)=0
34876          K(8,5)=0
34877       ENDIF
34878 c      WRITE(*,*)
34879 c      WRITE(*,*)
34880
34881 c      IF(PMODUL.GE.1.D+00) THEN
34882 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34883 c        write(*,*) pmodul
34884 c        DO I=1,3
34885 c          POL(4,I)=POL(4,I)/PMODUL
34886 c          POLARX(I)=POL(4,I)
34887 c        END DO
34888 c        PMODUL=0.
34889 c        DO I=1,3
34890 c          PMODUL=PMODUL+POL(4,I)**2
34891 c        END DO
34892 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34893 c
34894 c      ENDIF
34895
34896 c      WRITE(*,*) 'PMODUL = ',PMODUL
34897
34898 c      WRITE(*,*)
34899 c      WRITE(*,*)
34900 c      WRITE(*,*) 'prepola: Now back to nucl rest frame'
34901
34902       CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
34903
34904       XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
34905       YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
34906       ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
34907       DO NDC =6,8
34908          V(NDC,1) = XDC
34909          V(NDC,2) = YDC
34910          V(NDC,3) = ZDC
34911       END DO
34912
34913       RETURN
34914       END
34915
34916 *$ CREATE DT_TESTROT.FOR
34917 *COPY DT_TESTROT
34918 *
34919 *===testrot============================================================*
34920 *
34921       SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
34922
34923       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34924       SAVE
34925
34926       DIMENSION ROT(3,3),PI(3),PO(3)
34927
34928       IF (MODE.EQ.1) THEN
34929          ROT(1,1) = 1.D0
34930          ROT(1,2) = 0.D0
34931          ROT(1,3) = 0.D0
34932          ROT(2,1) = 0.D0
34933          ROT(2,2) = COS(PHI)
34934          ROT(2,3) = -SIN(PHI)
34935          ROT(3,1) = 0.D0
34936          ROT(3,2) = SIN(PHI)
34937          ROT(3,3) = COS(PHI)
34938       ELSEIF (MODE.EQ.2) THEN
34939          ROT(1,1) = 0.D0
34940          ROT(1,2) = 1.D0
34941          ROT(1,3) = 0.D0
34942          ROT(2,1) = COS(PHI)
34943          ROT(2,2) = 0.D0
34944          ROT(2,3) = -SIN(PHI)
34945          ROT(3,1) = SIN(PHI)
34946          ROT(3,2) = 0.D0
34947          ROT(3,3) = COS(PHI)
34948       ELSEIF (MODE.EQ.3) THEN
34949          ROT(1,1) = 0.D0
34950          ROT(2,1) = 1.D0
34951          ROT(3,1) = 0.D0
34952          ROT(1,2) = COS(PHI)
34953          ROT(2,2) = 0.D0
34954          ROT(3,2) = -SIN(PHI)
34955          ROT(1,3) = SIN(PHI)
34956          ROT(2,3) = 0.D0
34957          ROT(3,3) = COS(PHI)
34958       ELSEIF (MODE.EQ.4) THEN
34959          ROT(1,1) = 1.D0
34960          ROT(2,1) = 0.D0
34961          ROT(3,1) = 0.D0
34962          ROT(1,2) = 0.D0
34963          ROT(2,2) = COS(PHI)
34964          ROT(3,2) = -SIN(PHI)
34965          ROT(1,3) = 0.D0
34966          ROT(2,3) = SIN(PHI)
34967          ROT(3,3) = COS(PHI)
34968       ELSE
34969          STOP ' TESTROT: mode not supported!'
34970       ENDIF
34971       DO 1 J=1,3
34972         PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
34973     1 CONTINUE
34974
34975       RETURN
34976       END
34977
34978 *$ CREATE DT_LEPDCYP.FOR
34979 *COPY DT_LEPDCYP
34980 *
34981 *===lepdcyp============================================================*
34982 *
34983       SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
34984      &                      ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34985 C
34986 C-----------------------------------------------------------------
34987 C
34988 C   Author   :- G. Battistoni         10-NOV-1995
34989 C
34990 C=================================================================
34991 C
34992 C   Purpose   : performs decay of polarized lepton in
34993 C               its rest frame: a => b + l + anti-nu
34994 C               (Example: mu- => nu-mu + e- + anti-nu-e)
34995 C               Polarization is assumed along Z-axis
34996 C               WARNING:
34997 C               1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
34998 C                  OF NEGLIGIBLE MASS
34999 C               2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
35000 C                  IN THIS VERSION
35001 C
35002 C   Method    : modifies phase space distribution obtained
35003 C               by routine EXPLOD using a rejection against the
35004 C               matrix element for unpolarized lepton decay
35005 C
35006 C   Inputs    : Mass of a :  AMA
35007 C               Mass of l :  AML
35008 C               Polar. of a: POL
35009 C               (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
35010 C                                                 POL = -1)
35011 C
35012 C   Outputs   : kinematic variables in the rest frame of decaying lepton
35013 C               ETL,PXL,PYL,PZL 4-moment of l
35014 C               ETB,PXB,PYB,PZB 4-moment of b
35015 C               ETN,PXN,PYN,PZN 4-moment of anti-nu
35016 C
35017 C============================================================
35018 C +
35019 C Declarations.
35020 C -
35021       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35022       SAVE
35023
35024       PARAMETER ( LINP = 10 ,
35025      &            LOUT = 6 ,
35026      &            LDAT = 9 )
35027
35028       PARAMETER ( KALGNM = 2 )
35029       PARAMETER ( ANGLGB = 5.0D-16 )
35030       PARAMETER ( ANGLSQ = 2.5D-31 )
35031       PARAMETER ( AXCSSV = 0.2D+16 )
35032       PARAMETER ( ANDRFL = 1.0D-38 )
35033       PARAMETER ( AVRFLW = 1.0D+38 )
35034       PARAMETER ( AINFNT = 1.0D+30 )
35035       PARAMETER ( AZRZRZ = 1.0D-30 )
35036       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
35037       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
35038       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
35039       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
35040       PARAMETER ( CSNNRM = 2.0D-15 )
35041       PARAMETER ( DMXTRN = 1.0D+08 )
35042       PARAMETER ( ZERZER = 0.D+00 )
35043       PARAMETER ( ONEONE = 1.D+00 )
35044       PARAMETER ( TWOTWO = 2.D+00 )
35045       PARAMETER ( THRTHR = 3.D+00 )
35046       PARAMETER ( FOUFOU = 4.D+00 )
35047       PARAMETER ( FIVFIV = 5.D+00 )
35048       PARAMETER ( SIXSIX = 6.D+00 )
35049       PARAMETER ( SEVSEV = 7.D+00 )
35050       PARAMETER ( EIGEIG = 8.D+00 )
35051       PARAMETER ( ANINEN = 9.D+00 )
35052       PARAMETER ( TENTEN = 10.D+00 )
35053       PARAMETER ( HLFHLF = 0.5D+00 )
35054       PARAMETER ( ONETHI = ONEONE / THRTHR )
35055       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
35056       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
35057       PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
35058       PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
35059       PARAMETER ( CLIGHT = 2.99792458         D+10 )
35060       PARAMETER ( AVOGAD = 6.0221367          D+23 )
35061       PARAMETER ( AMELGR = 9.1093897          D-28 )
35062       PARAMETER ( PLCKBR = 1.05457266         D-27 )
35063       PARAMETER ( ELCCGS = 4.8032068          D-10 )
35064       PARAMETER ( ELCMKS = 1.60217733         D-19 )
35065       PARAMETER ( AMUGRM = 1.6605402          D-24 )
35066       PARAMETER ( AMMUMU = 0.113428913        D+00 )
35067       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
35068       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
35069       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
35070       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
35071       PARAMETER ( PLABRC = 0.197327053        D+00 )
35072       PARAMETER ( AMELCT = 0.51099906         D-03 )
35073       PARAMETER ( AMUGEV = 0.93149432         D+00 )
35074       PARAMETER ( AMMUON = 0.105658389        D+00 )
35075       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
35076       PARAMETER ( GEVMEV = 1.0                D+03 )
35077       PARAMETER ( EMVGEV = 1.0                D-03 )
35078       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
35079       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
35080       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
35081 C +
35082 C    variables for EXPLOD
35083 C -
35084       PARAMETER ( KPMX = 10 )
35085       DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
35086      &          PZEXPL (KPMX), ETEXPL (KPMX)
35087 C +
35088 C      test variables
35089 C -
35090 **sr - removed (not needed)
35091 C     COMMON /GBATNU/ ELERAT,NTRY
35092 **
35093 C +
35094 C     Initializes test variables
35095 C -
35096       NTRY = 0
35097       ELERAT = 0.D+00
35098 C +
35099 C     Maximum value for matrix element
35100 C -
35101       ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
35102      &  SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
35103 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
35104 C     Inputs for EXPLOD
35105 C part. no. 1 is l       (e- in mu- decay)
35106 C part. no. 2 is b       (nu-mu in mu- decay)
35107 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
35108 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
35109       NPEXPL = 3
35110       ETOTEX = AMA
35111       AMEXPL(1) = AML
35112       AMEXPL(2) = 0.D+00
35113       AMEXPL(3) = 0.D+00
35114 C +
35115 C     phase space distribution
35116 C -
35117   100 CONTINUE
35118       NTRY = NTRY + 1
35119
35120       CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
35121      &              PYEXPL, PZEXPL )
35122
35123 C +
35124 C  Calculates matrix element:
35125 C  64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
35126 C  Here CTH is the cosine of the angle between anti-nu and Z axis
35127 C -
35128       CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
35129      &  PZEXPL(3)**2 )
35130       PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
35131       PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
35132      &     PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
35133       ELEMAT = 16.D+00 * PROD1 * PROD2
35134       IF(ELEMAT.GT.ELEMAX) THEN
35135         WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
35136         STOP
35137       ENDIF
35138 C +
35139 C     Here performs the rejection
35140 C -
35141       TEST = DT_RNDM(ETOTEX) * ELEMAX
35142       IF ( TEST .GT. ELEMAT ) GO TO 100
35143 C +
35144 C     final assignment of variables
35145 C -
35146       ELERAT = ELEMAT/ELEMAX
35147       ETL = ETEXPL(1)
35148       PXL = PXEXPL(1)
35149       PYL = PYEXPL(1)
35150       PZL = PZEXPL(1)
35151       ETB = ETEXPL(2)
35152       PXB = PXEXPL(2)
35153       PYB = PYEXPL(2)
35154       PZB = PZEXPL(2)
35155       ETN = ETEXPL(3)
35156       PXN = PXEXPL(3)
35157       PYN = PYEXPL(3)
35158       PZN = PZEXPL(3)
35159   999 RETURN
35160       END
35161
35162 *$ CREATE DT_GEN_DELTA.FOR
35163 *COPY DT_GEN_DELTA
35164 C==================================================================
35165 C.  Generation of  Delta resonance events
35166 C==================================================================
35167 *
35168 *===gen_delta==========================================================*
35169 *
35170       SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
35171
35172       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35173       SAVE
35174
35175       PARAMETER ( LINP = 10 ,
35176      &            LOUT = 6 ,
35177      &            LDAT = 9 )
35178
35179 C...Generate a Delta-production neutrino/antineutrino
35180 C.  CC-interaction on a nucleon
35181 C
35182 C.  INPUT  ENU (GeV) = Neutrino Energy
35183 C.         LLEP = neutrino type
35184 C.         LTARG = nucleon target type 1=p, 2=n.
35185 C.         JINT = 1:CC, 2::NC
35186 C.
35187 C.  OUTPUT PPL(4)  4-monentum of final lepton
35188 C----------------------------------------------------
35189       PARAMETER (MAXLND=4000)
35190       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35191
35192 **sr - removed (not needed)
35193 C     COMMON /CBAD/  LBAD, NBAD
35194 **
35195
35196       DIMENSION PI(3),PO(3)
35197 C     REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
35198       DIMENSION AML0(6),AMN(2)
35199       DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
35200       DATA AMN  /0.93827231, 0.93956563/
35201       DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
35202
35203 c     WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
35204       LBAD = 0
35205 C...Final lepton mass
35206       IF (JINT.EQ.1) THEN
35207         AML = AML0(LLEP)
35208       ELSE
35209         AML = 0.
35210       ENDIF
35211       AML2 = AML**2
35212
35213 C...Particle labels (LUND)
35214       N = 5
35215       K(1,1) = 21
35216       K(2,1) = 21
35217       K(3,1) = 21
35218       K(4,1) = 1
35219       K(3,3) = 1
35220       K(4,3) = 1
35221       IF (LTARG .EQ. 1)  THEN
35222          K(2,2) = 2212
35223       ELSE
35224          K(2,2) = 2112
35225       ENDIF
35226       K0 = (LLEP-1)/2
35227       K1 = LLEP/2
35228       KA = 12 + 2*K0
35229       IS = -1 + 2*LLEP - 4*K1
35230       LNU = 2 - LLEP + 2*K1
35231       K(1,2) = IS*KA
35232       K(5,1) = 1
35233       K(5,3) = 2
35234       IF (JINT .EQ. 1)  THEN                    ! CC interactions
35235          K(3,2) = IS*24
35236          K(4,2) = IS*(KA-1)
35237         IF(LNU.EQ.1) THEN
35238           IF (LTARG .EQ. 1)  THEN
35239               K(5,2) = 2224
35240           ELSE
35241               K(5,2) = 2214
35242           ENDIF
35243         ELSE
35244           IF (LTARG .EQ. 1)  THEN
35245               K(5,2) = 2114
35246           ELSE
35247               K(5,2) = 1114
35248           ENDIF
35249         ENDIF
35250       ELSE
35251          K(3,2) = 23                           ! NC (Z0) interactions
35252          K(4,2) = K(1,2)
35253 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
35254 *                                Delta0 for neutron (LTARG=2)
35255 C        IF (LTARG .EQ. 1)  THEN
35256 C           K(5,2) = 2114
35257 C        ELSE
35258 C           K(5,2) = 2214
35259 C        ENDIF
35260          IF (LTARG .EQ. 1)  THEN
35261             K(5,2) = 2214
35262          ELSE
35263             K(5,2) = 2114
35264          ENDIF
35265 **
35266       ENDIF
35267
35268 C...4-momentum initial lepton
35269       P(1,5) = 0.
35270       P(1,4) = ENU
35271       P(1,1) = 0.
35272       P(1,2) = 0.
35273       P(1,3) = ENU
35274 C...4-momentum initial nucleon
35275       P(2,5) = AMN(LTARG)
35276 C     P(2,4) = P(2,5)
35277 C     P(2,1) = 0.
35278 C     P(2,2) = 0.
35279 C     P(2,3) = 0.
35280        P(2,1) = P21
35281        P(2,2) = P22
35282        P(2,3) = P23
35283        P(2,4) = P24
35284        P(2,5) = P25
35285       N=2
35286       beta1=-p(2,1)/p(2,4)
35287       beta2=-p(2,2)/p(2,4)
35288       beta3=-p(2,3)/p(2,4)
35289       N=2
35290
35291       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35292
35293 C     print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35294
35295       phi11=atan(p(1,2)/p(1,3))
35296       pi(1)=p(1,1)
35297       pi(2)=p(1,2)
35298       pi(3)=p(1,3)
35299
35300       CALL DT_TESTROT(PI,Po,PHI11,1)
35301       DO ll=1,3
35302        IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35303       END DO
35304       p(1,1)=po(1)
35305       p(1,2)=po(2)
35306       p(1,3)=po(3)
35307       phi12=atan(p(1,1)/p(1,3))
35308
35309       pi(1)=p(1,1)
35310       pi(2)=p(1,2)
35311       pi(3)=p(1,3)
35312       CALL DT_TESTROT(Pi,Po,PHI12,2)
35313       DO ll=1,3
35314         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35315       END DO
35316       p(1,1)=po(1)
35317       p(1,2)=po(2)
35318       p(1,3)=po(3)
35319
35320       ENUU=P(1,4)
35321
35322 C...Generate the Mass of the Delta
35323       NTRY = 0
35324 100   R = PYR(0)
35325       AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
35326       NTRY = NTRY + 1
35327       IF (NTRY .GT. 1000)  THEN
35328          LBAD = 1
35329          WRITE (LOUT,1001)  NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
35330          RETURN
35331       ENDIF
35332       IF (AMD .LT. AMDMIN)  GOTO 100
35333       ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
35334       IF (ENUU .LT. ET) GOTO 100
35335
35336 C...Kinematical  limits in Q**2
35337       S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
35338       SQS = SQRT(S)
35339       PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
35340       ELF = (S - AMD**2 + AML2)/(2.*SQS)
35341       PLF = SQRT(ELF**2 - AML2)
35342       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
35343       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
35344       IF (Q2MIN .LT. 0.)   Q2MIN = 0.
35345
35346       DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
35347 200   Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35348       DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
35349       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
35350
35351 C...Generate the kinematics of the final particles
35352       EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
35353       GAM = EISTAR/AMN(LTARG)
35354       BET = PSTAR/EISTAR
35355       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
35356       EL  = GAM*(ELF + BET*PLF*CTSTAR)
35357       PLZ = GAM*(PLF*CTSTAR + BET*ELF)
35358       PL  = SQRT(EL**2 - AML2)
35359       PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
35360       PHI = 6.28319*PYR(0)
35361       P(4,1) = PLT*COS(PHI)
35362       P(4,2) = PLT*SIN(PHI)
35363       P(4,3) = PLZ
35364       P(4,4) = EL
35365       P(4,5) = AML
35366
35367 C...4-momentum of Delta
35368       P(5,1) = -P(4,1)
35369       P(5,2) = -P(4,2)
35370       P(5,3) = ENUU-P(4,3)
35371       P(5,4) = ENUU+AMN(LTARG)-P(4,4)
35372       P(5,5) = AMD
35373
35374 C...4-momentum  of intermediate boson
35375       P(3,5) = -Q2
35376       P(3,4) = P(1,4)-P(4,4)
35377       P(3,1) = P(1,1)-P(4,1)
35378       P(3,2) = P(1,2)-P(4,2)
35379       P(3,3) = P(1,3)-P(4,3)
35380       N=5
35381
35382       DO kw=1,5
35383         pi(1)=p(kw,1)
35384         pi(2)=p(kw,2)
35385         pi(3)=p(kw,3)
35386         CALL DT_TESTROT(Pi,Po,PHI12,3)
35387         DO ll=1,3
35388           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35389         END DO
35390         p(kw,1)=po(1)
35391         p(kw,2)=po(2)
35392         p(kw,3)=po(3)
35393       END DO
35394
35395 c********************************************
35396
35397         DO kw=1,5
35398           pi(1)=p(kw,1)
35399           pi(2)=p(kw,2)
35400           pi(3)=p(kw,3)
35401           CALL DT_TESTROT(Pi,Po,PHI11,4)
35402           DO ll=1,3
35403             IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35404           END DO
35405           p(kw,1)=po(1)
35406           p(kw,2)=po(2)
35407           p(kw,3)=po(3)
35408        END DO
35409 c********************************************
35410 C         transform back into Lab.
35411
35412       CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35413
35414 C     WRITE(6,*)' Lab fram ( fermi incl.) '
35415       N=5
35416       CALL PYEXEC
35417
35418       RETURN
35419 1001  FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5,  6G10.3)
35420       END
35421
35422 *$ CREATE DT_DSIGMA_DELTA.FOR
35423 *COPY DT_DSIGMA_DELTA
35424 *
35425 *===dsigma_delta=======================================================*
35426 *
35427       DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
35428
35429       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35430       SAVE
35431
35432 C...Reaction nu + N -> lepton + Delta
35433 C.  returns the  cross section
35434 C.  dsigma/dt
35435 C.  INPUT  LNU = 1, 2  (neutrino-antineutrino)
35436 C.         QQ = t (always negative)  GeV**2
35437 C.         S  = (c.m energy)**2      GeV**2
35438 C.  OUTPUT =  10**-38 cm+2/GeV**2
35439 C-----------------------------------------------------
35440       REAL*8 MN, MN2, MN4, MD,MD2, MD4
35441       DATA MN /0.938/
35442       DATA PI /3.1415926/
35443
35444       GF = (1.1664 * 1.97)
35445       GF2 = GF*GF
35446       MN2 = MN*MN
35447       MN4 = MN2*MN2
35448       MD2 = MD*MD
35449       MD4 = MD2*MD2
35450       AML2 = AML*AML
35451       AML4 = AML2*AML2
35452       VQ  = (MN2 - MD2 - QQ)/2.
35453       VPI = (MN2 + MD2 - QQ)/2.
35454       VK  = (S + QQ - MN2 - AML2)/2.
35455       PIK = (S - MN2)/2.
35456       QK = (AML2 - QQ)/2.
35457       PIQ = (QQ + MN2 - MD2)/2.
35458       Q = SQRT(-QQ)
35459       C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
35460       C3 = SQRT(3.)*C3V/MN
35461       C4 = -C3/MD             ! attenzione al segno
35462       C5A = 1.18/(1.-QQ/0.4225)**2
35463       C32 = C3**2
35464       C42 = C4**2
35465       C5A2 = C5A**2
35466
35467       IF (LNU .EQ. 1)  THEN
35468       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35469      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35470      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35471      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35472       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35473      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35474      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35475      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35476      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35477      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
35478      . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35479      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35480      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35481      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35482      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
35483      . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
35484      . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
35485      . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
35486      . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
35487      . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35488      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35489      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35490      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35491       ELSE
35492       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35493      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35494      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35495      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35496       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35497      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35498      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35499      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35500      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35501      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
35502      . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35503      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35504      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35505      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35506      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
35507      . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
35508      . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
35509      . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
35510      . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
35511      . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35512      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35513      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35514      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35515       ENDIF
35516       ANS1=32.*ANS2
35517       ANS=ANS1/(3.*MD2)
35518       P1CM = (S-MN2)/(2.*SQRT(S))
35519       DT_DSIGMA_DELTA  = GF2/2. * ANS/(64.*PI*S*P1CM**2)
35520
35521       RETURN
35522       END
35523
35524 *$ CREATE DT_QGAUS.FOR
35525 *COPY DT_QGAUS
35526 *
35527 *===qgaus==============================================================*
35528 *
35529       SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
35530
35531       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35532       SAVE
35533
35534       DIMENSION X(5),W(5)
35535       DATA X/.1488743389D0,.4333953941D0,
35536      & .6794095682D0,.8650633666D0,.9739065285D0
35537      */
35538       DATA W/.2955242247D0,.2692667193D0,
35539      & .2190863625D0,.1494513491D0,.0666713443D0
35540      */
35541       XM=0.5D0*(B+A)
35542       XR=0.5D0*(B-A)
35543       SS=0
35544       DO 11 J=1,5
35545         DX=XR*X(J)
35546         SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
35547      &  DT_DSQEL_Q2(LTYP,ENU,XM-DX))
35548 11    CONTINUE
35549       SS=XR*SS
35550
35551       RETURN
35552       END
35553 *$ CREATE DT_DIQBRK.FOR
35554 *COPY DT_DIQBRK
35555 *
35556 *===diqbrk=============================================================*
35557 *
35558       SUBROUTINE DT_DIQBRK
35559
35560       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35561       SAVE
35562
35563 * event history
35564
35565       PARAMETER (NMXHKK=200000)
35566
35567       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35568      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35569      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35570
35571 * extended event history
35572       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35573      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35574      &                IHIST(2,NMXHKK)
35575
35576 * event flag
35577       COMMON /DTEVNO/ NEVENT,ICASCA
35578
35579 C     IF(DT_RNDM(VV).LE.0.5D0)THEN
35580 C       CALL GSQBS1(NHKK)
35581 C       CALL GSQBS2(NHKK)
35582 C       CALL USQBS1(NHKK)
35583 C       CALL USQBS2(NHKK)
35584 C       CALL GSABS1(NHKK)
35585 C       CALL GSABS2(NHKK)
35586 C       CALL USABS1(NHKK)
35587 C       CALL USABS2(NHKK)
35588 C     ELSE
35589 C       CALL GSQBS2(NHKK)
35590 C       CALL GSQBS1(NHKK)
35591 C       CALL USQBS2(NHKK)
35592 C       CALL USQBS1(NHKK)
35593 C       CALL GSABS2(NHKK)
35594 C       CALL GSABS1(NHKK)
35595 C       CALL USABS2(NHKK)
35596 C       CALL USABS1(NHKK)
35597 C     ENDIF
35598
35599       IF(DT_RNDM(VV).LE.0.5D0) THEN
35600         CALL DT_DBREAK(1)
35601         CALL DT_DBREAK(2)
35602         CALL DT_DBREAK(3)
35603         CALL DT_DBREAK(4)
35604         CALL DT_DBREAK(5)
35605         CALL DT_DBREAK(6)
35606         CALL DT_DBREAK(7)
35607         CALL DT_DBREAK(8)
35608       ELSE
35609         CALL DT_DBREAK(2)
35610         CALL DT_DBREAK(1)
35611         CALL DT_DBREAK(4)
35612         CALL DT_DBREAK(3)
35613         CALL DT_DBREAK(6)
35614         CALL DT_DBREAK(5)
35615         CALL DT_DBREAK(8)
35616         CALL DT_DBREAK(7)
35617       ENDIF
35618
35619       RETURN
35620       END
35621
35622 *$ CREATE MUSQBS2.FOR
35623 *COPY MUSQBS2
35624 C
35625 C
35626 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
35627       SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35628      *              IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
35629 C
35630 C                  USQBS-2 diagram (split target diquark)
35631 C
35632       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35633       SAVE
35634
35635       PARAMETER ( LINP = 10 ,
35636      &            LOUT = 6 ,
35637      &            LDAT = 9 )
35638
35639 * event history
35640
35641       PARAMETER (NMXHKK=200000)
35642
35643       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35644      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35645      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35646
35647 * extended event history
35648       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35649      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35650      &                IHIST(2,NMXHKK)
35651
35652 * Lorentz-parameters of the current interaction
35653       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
35654      &                UMO,PPCM,EPROJ,PPROJ
35655
35656 * diquark-breaking mechanism
35657       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
35658
35659 C
35660       PARAMETER (NTMHKK= 300)
35661       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35662      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35663      +(4,NTMHKK)
35664 *KEEP,XSEADI.
35665       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
35666      +SSMIMQ,VVMTHR
35667 *KEEP,DPRIN.
35668       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
35669       COMMON /EVFLAG/ NUMEV
35670 C
35671 C                  USQBS-2 diagram (split target diquark)
35672 C
35673 C
35674 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
35675 C     Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
35676 C
35677 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
35678 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35679 C
35680 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35681 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35682 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35683 C
35684 C
35685 C       Put new chains into COMMON /HKKTMP/
35686 C
35687       IIGLU1=NC1T-NC1P-1
35688       IIGLU2=NC2T-NC2P-1
35689       IGCOUN=0
35690 C     WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
35691       CVQ=1.D0
35692       IREJ=0
35693       IF(IPIP.EQ.2)THEN
35694 C     IF(NUMEV.EQ.-324)THEN
35695 C     WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
35696 C    *             'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
35697 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35698 C    *              IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
35699       ENDIF
35700 C
35701 C
35702 C
35703 C     determine x-values of NC1T diquark
35704       XDIQT=PHKK(4,NC1T)*2.D0/UMO
35705       XVQP=PHKK(4,NC1P)*2.D0/UMO
35706 C
35707 C     determine x-values of sea quark pair
35708 C
35709       IPCO=1
35710       ICOU=0
35711  2234 CONTINUE
35712       ICOU=ICOU+1
35713       IF(ICOU.GE.500)THEN
35714         IREJ=1
35715         IF(ISQ.EQ.3)IREJ=3
35716         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
35717         IPCO=0
35718         RETURN
35719       ENDIF
35720       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
35721      * UMO, XDIQT,XVQP
35722       XSQ=0.D0
35723       XSAQ=0.D0
35724 **NEW
35725 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
35726       IF (IPIP.EQ.1) THEN
35727          XQMAX  = XDIQT/2.0D0
35728          XAQMAX = 2.D0*XVQP/3.0D0
35729       ELSE
35730          XQMAX  = 2.D0*XVQP/3.0D0
35731          XAQMAX = XDIQT/2.0D0
35732       ENDIF
35733       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
35734       ISAQ = 6+ISQ
35735 C     write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
35736 **
35737         IF(IPCO.GE.3)
35738      &     WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35739       IF(IREJ.GE.1)THEN
35740         IF(IPCO.GE.3)
35741      &     WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35742         IPCO=0
35743         RETURN
35744       ENDIF
35745       IF(IPIP.EQ.1)THEN
35746         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35747       ELSEIF(IPIP.EQ.2)THEN
35748         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35749       ENDIF
35750       IF(IPCO.GE.3)THEN
35751         WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
35752      &  XDIQT,XVQP,XSQ,XSAQ
35753       ENDIF
35754 C
35755 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
35756 C
35757 C     XSQ=0.D0
35758       IF(IPIP.EQ.1)THEN
35759         XDIQT=XDIQT-XSQ
35760         XVQP =XVQP -XSAQ
35761       ELSEIF(IPIP.EQ.2)THEN
35762         XDIQT=XDIQT-XSAQ
35763         XVQP =XVQP -XSQ
35764       ENDIF
35765       IF(IPCO.GE.3)
35766      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
35767 C
35768 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35769 C
35770       XVTHRO=CVQ/UMO
35771       IVTHR=0
35772  3466 CONTINUE
35773       IF(IVTHR.EQ.10)THEN
35774         IREJ=1
35775         IF(ISQ.EQ.3)IREJ=3
35776         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
35777       IPCO=0
35778         RETURN
35779       ENDIF
35780       IVTHR=IVTHR+1
35781       XVTHR=XVTHRO/(201-IVTHR)
35782       UNOPRV=UNON
35783  380  CONTINUE
35784       IF(XVTHR.GT.0.66D0*XDIQT)THEN
35785         IREJ=1
35786         IF(ISQ.EQ.3)IREJ=3
35787         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR  large',
35788      *  XVTHR
35789       IPCO=0
35790         RETURN
35791       ENDIF
35792       IF(DT_RNDM(V).LT.0.5D0)THEN
35793         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35794         XVTQII=XDIQT-XVTQI
35795       ELSE
35796         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35797         XVTQI=XDIQT-XVTQII
35798       ENDIF
35799       IF(IPCO.GE.3)THEN
35800         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
35801       ENDIF
35802 C
35803 C     Prepare 4 momenta of new chains and chain ends
35804 C
35805 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35806 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35807 C    +(4,NTMHKK)
35808 C
35809 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35810 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35811 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35812 C
35813 C     SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35814 C    *              IP1,IP21,IP22,IPP1,IPP2)
35815 C
35816       IF(IPIP.EQ.1)THEN
35817         XSQ1=XSQ
35818         XSAQ1=XSAQ
35819         ISQ1=ISQ
35820         ISAQ1=ISAQ
35821       ELSEIF(IPIP.EQ.2)THEN
35822         XSQ1=XSAQ
35823         XSAQ1=XSQ
35824         ISQ1=ISAQ
35825         ISAQ1=ISQ
35826       ENDIF
35827       IDHKT(1)   =IPP1
35828       ISTHKT(1)  =951
35829       JMOHKT(1,1)=NC2P
35830       JMOHKT(2,1)=0
35831       JDAHKT(1,1)=3+IIGLU1
35832       JDAHKT(2,1)=0
35833 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35834       PHKT(1,1)  =PHKK(1,NC2P)
35835       PHKT(2,1)  =PHKK(2,NC2P)
35836       PHKT(3,1)  =PHKK(3,NC2P)
35837       PHKT(4,1)  =PHKK(4,NC2P)
35838 C     PHKT(5,1)  =PHKK(5,NC2P)
35839       XMIST  =(PHKT(4,1)**2-
35840      * PHKT(3,1)**2-PHKT(2,1)**2-
35841      *PHKT(1,1)**2)
35842       IF(XMIST.GT.0.D0)THEN
35843       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35844      *PHKT(1,1)**2)
35845       ELSE
35846 C     WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
35847       PHKT(5,1)=0.D0
35848       ENDIF
35849       VHKT(1,1)  =VHKK(1,NC2P)
35850       VHKT(2,1)  =VHKK(2,NC2P)
35851       VHKT(3,1)  =VHKK(3,NC2P)
35852       VHKT(4,1)  =VHKK(4,NC2P)
35853       WHKT(1,1)  =WHKK(1,NC2P)
35854       WHKT(2,1)  =WHKK(2,NC2P)
35855       WHKT(3,1)  =WHKK(3,NC2P)
35856       WHKT(4,1)  =WHKK(4,NC2P)
35857 C     Add here IIGLU1 gluons to this chaina
35858       PG1=0.D0
35859       PG2=0.D0
35860       PG3=0.D0
35861       PG4=0.D0
35862       IF(IIGLU1.GE.1)THEN
35863       JJG=NC1P
35864       DO 61 IIG=2,2+IIGLU1-1
35865         KKG=JJG+IIG-1
35866         IDHKT(IIG)   =IDHKK(KKG)
35867         ISTHKT(IIG)  =921
35868         JMOHKT(1,IIG)=KKG
35869         JMOHKT(2,IIG)=0
35870         JDAHKT(1,IIG)=3+IIGLU1
35871         JDAHKT(2,IIG)=0
35872         PHKT(1,IIG)=PHKK(1,KKG)
35873         PG1=PG1+ PHKT(1,IIG)
35874         PHKT(2,IIG)=PHKK(2,KKG)
35875         PG2=PG2+ PHKT(2,IIG)
35876         PHKT(3,IIG)=PHKK(3,KKG)
35877         PG3=PG3+ PHKT(3,IIG)
35878         PHKT(4,IIG)=PHKK(4,KKG)
35879         PG4=PG4+ PHKT(4,IIG)
35880         PHKT(5,IIG)=PHKK(5,KKG)
35881         VHKT(1,IIG)  =VHKK(1,KKG)
35882         VHKT(2,IIG)  =VHKK(2,KKG)
35883         VHKT(3,IIG)  =VHKK(3,KKG)
35884         VHKT(4,IIG)  =VHKK(4,KKG)
35885         WHKT(1,IIG) =WHKK(1,KKG)
35886         WHKT(2,IIG) =WHKK(2,KKG)
35887         WHKT(3,IIG) =WHKK(3,KKG)
35888         WHKT(4,IIG) =WHKK(4,KKG)
35889    61 CONTINUE
35890       ENDIF
35891       IDHKT(2+IIGLU1)   =IP21
35892       ISTHKT(2+IIGLU1)  =952
35893       JMOHKT(1,2+IIGLU1)=NC1T
35894       JMOHKT(2,2+IIGLU1)=0
35895       JDAHKT(1,2+IIGLU1)=3+IIGLU1
35896       JDAHKT(2,2+IIGLU1)=0
35897       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
35898       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
35899       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
35900       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
35901 C     PHKT(5,2)  =PHKK(5,NC1T)
35902       XMIST  =(PHKT(4,2+IIGLU1)**2-
35903      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35904      *PHKT(1,2+IIGLU1)**2)
35905       IF(XMIST.GT.0.D0)THEN
35906       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
35907      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35908      *PHKT(1,2+IIGLU1)**2)
35909       ELSE
35910 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35911         PHKT(5,5+IIGLU1)=0.D0
35912       ENDIF
35913       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
35914       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
35915       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
35916       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
35917       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
35918       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
35919       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
35920       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
35921       IDHKT(3+IIGLU1)   =88888
35922       ISTHKT(3+IIGLU1)  =95
35923       JMOHKT(1,3+IIGLU1)=1
35924       JMOHKT(2,3+IIGLU1)=2+IIGLU1
35925       JDAHKT(1,3+IIGLU1)=0
35926       JDAHKT(2,3+IIGLU1)=0
35927       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35928       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35929       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35930       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35931       XMIST
35932      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35933      *            -PHKT(3,3+IIGLU1)**2)
35934       IF(XMIST.GT.0.D0)THEN
35935       PHKT(5,3+IIGLU1)
35936      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35937      *            -PHKT(3,3+IIGLU1)**2)
35938       ELSE
35939 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35940         PHKT(5,5+IIGLU1)=0.D0
35941       ENDIF
35942       IF(IPIP.GE.2)THEN
35943 C     IF(NUMEV.EQ.-324)THEN
35944 C     WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
35945 C    * JDAHKT(1,1),
35946 C    *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35947       DO 71 IIG=2,2+IIGLU1-1
35948 C     WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35949 C    &             JMOHKT(1,IIG),JMOHKT(2,IIG),
35950 C    * JDAHKT(1,IIG),
35951 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35952    71 CONTINUE
35953 C     WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35954 C    * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35955 C    *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35956 C     WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35957 C    * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35958 C    *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35959       ENDIF
35960       CHAMAL=CHAM1
35961       IF(IPIP.EQ.1)THEN
35962         IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
35963       ELSEIF(IPIP.EQ.2)THEN
35964         IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
35965       ENDIF
35966       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35967 C       IREJ=1
35968         IPCO=0
35969 C       RETURN
35970 C       WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
35971         GO TO 3466
35972       ENDIF
35973       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
35974       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
35975       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
35976       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
35977       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
35978       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
35979       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
35980       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
35981       IF(IPIP.EQ.1)THEN
35982         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
35983       ELSEIF(IPIP.EQ.2)THEN
35984         IDHKT(4+IIGLU1)   =ISAQ1
35985       ENDIF
35986       ISTHKT(4+IIGLU1)  =951
35987       JMOHKT(1,4+IIGLU1)=NC1P
35988       JMOHKT(2,4+IIGLU1)=0
35989       JDAHKT(1,4+IIGLU1)=6+IIGLU1
35990       JDAHKT(2,4+IIGLU1)=0
35991 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35992       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
35993       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
35994       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
35995       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
35996 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
35997       XMIST  =(PHKT(4,4+IIGLU1)**2-
35998      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
35999      *PHKT(1,4+IIGLU1)**2)
36000       IF(XMIST.GT.0.D0)THEN
36001       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
36002      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36003      *PHKT(1,4+IIGLU1)**2)
36004       ELSE
36005 C     WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
36006       PHKT(5,4+IIGLU1)=0.D0
36007       ENDIF
36008       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
36009       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
36010       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
36011       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
36012       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
36013       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
36014       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
36015       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
36016       IDHKT(5+IIGLU1)   =IP22
36017       ISTHKT(5+IIGLU1)  =952
36018       JMOHKT(1,5+IIGLU1)=NC1T
36019       JMOHKT(2,5+IIGLU1)=0
36020       JDAHKT(1,5+IIGLU1)=6+IIGLU1
36021       JDAHKT(2,5+IIGLU1)=0
36022       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36023       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36024       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36025       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36026 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
36027       XMIST  =(PHKT(4,5+IIGLU1)**2-
36028      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36029      *PHKT(1,5+IIGLU1)**2)
36030       IF(XMIST.GT.0.D0)THEN
36031       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
36032      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36033      *PHKT(1,5+IIGLU1)**2)
36034       ELSE
36035 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36036         PHKT(5,5+IIGLU1)=0.D0
36037       ENDIF
36038       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
36039       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
36040       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
36041       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
36042       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
36043       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
36044       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
36045       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
36046       IDHKT(6+IIGLU1)   =88888
36047       ISTHKT(6+IIGLU1)  =95
36048       JMOHKT(1,6+IIGLU1)=4+IIGLU1
36049       JMOHKT(2,6+IIGLU1)=5+IIGLU1
36050       JDAHKT(1,6+IIGLU1)=0
36051       JDAHKT(2,6+IIGLU1)=0
36052       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36053       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36054       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36055       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36056       XMIST
36057      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36058      *            -PHKT(3,6+IIGLU1)**2)
36059       IF(XMIST.GT.0.D0)THEN
36060       PHKT(5,6+IIGLU1)
36061      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36062      *            -PHKT(3,6+IIGLU1)**2)
36063       ELSE
36064 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36065         PHKT(5,5+IIGLU1)=0.D0
36066       ENDIF
36067 C     IF(IPIP.GE.2)THEN
36068 C     IF(NUMEV.EQ.-324)THEN
36069 C     WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36070 C    * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36071 C    *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36072 C     WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36073 C    * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36074 C    *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36075 C     WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36076 C    * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36077 C    *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36078 C     ENDIF
36079       CHAMAL=CHAM1
36080       IF(IPIP.EQ.1)THEN
36081         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36082       ELSEIF(IPIP.EQ.2)THEN
36083         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36084       ENDIF
36085       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36086 C       IREJ=1
36087         IPCO=0
36088 C       RETURN
36089 C       WRITE(6,*)' MUSQBS1 jump back from chain 6',
36090 C    *  CHAMAL,PHKT(5,6+IIGLU1)
36091         GO TO 3466
36092       ENDIF
36093       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
36094       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
36095       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
36096       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
36097       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
36098       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
36099       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
36100       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
36101 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
36102       IDHKT(7+IIGLU1)   =IP1
36103       ISTHKT(7+IIGLU1)  =951
36104       JMOHKT(1,7+IIGLU1)=NC1P
36105       JMOHKT(2,7+IIGLU1)=0
36106 **NEW
36107 C     JDAHKT(1,7+IIGLU1)=9+IIGLU1
36108       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36109 **
36110       JDAHKT(2,7+IIGLU1)=0
36111       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36112       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36113       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36114       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36115 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
36116       XMIST  =(PHKT(4,7+IIGLU1)**2-
36117      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36118      *PHKT(1,7+IIGLU1)**2)
36119       IF(XMIST.GT.0.D0)THEN
36120       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
36121      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36122      *PHKT(1,7+IIGLU1)**2)
36123       ELSE
36124 C     WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
36125       PHKT(5,7+IIGLU1)=0.D0
36126       ENDIF
36127       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
36128       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
36129       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
36130       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
36131       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
36132       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
36133       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
36134       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
36135 C     Insert here the IIGLU2 gluons
36136       PG1=0.D0
36137       PG2=0.D0
36138       PG3=0.D0
36139       PG4=0.D0
36140       IF(IIGLU2.GE.1)THEN
36141       JJG=NC2P
36142       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36143         KKG=JJG+IIG-7-IIGLU1
36144         IDHKT(IIG)   =IDHKK(KKG)
36145         ISTHKT(IIG)  =921
36146         JMOHKT(1,IIG)=KKG
36147         JMOHKT(2,IIG)=0
36148         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36149         JDAHKT(2,IIG)=0
36150         PHKT(1,IIG)=PHKK(1,KKG)
36151         PG1=PG1+ PHKT(1,IIG)
36152         PHKT(2,IIG)=PHKK(2,KKG)
36153         PG2=PG2+ PHKT(2,IIG)
36154         PHKT(3,IIG)=PHKK(3,KKG)
36155         PG3=PG3+ PHKT(3,IIG)
36156         PHKT(4,IIG)=PHKK(4,KKG)
36157         PG4=PG4+ PHKT(4,IIG)
36158         PHKT(5,IIG)=PHKK(5,KKG)
36159         VHKT(1,IIG)  =VHKK(1,KKG)
36160         VHKT(2,IIG)  =VHKK(2,KKG)
36161         VHKT(3,IIG)  =VHKK(3,KKG)
36162         VHKT(4,IIG)  =VHKK(4,KKG)
36163         WHKT(1,IIG)  =WHKK(1,KKG)
36164         WHKT(2,IIG) =WHKK(2,KKG)
36165         WHKT(3,IIG) =WHKK(3,KKG)
36166         WHKT(4,IIG) =WHKK(4,KKG)
36167    81 CONTINUE
36168       ENDIF
36169       IF(IPIP.EQ.1)THEN
36170         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
36171         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36172         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36173         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36174       ELSEIF(IPIP.EQ.2)THEN
36175         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
36176         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36177         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36178         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36179       ENDIF
36180       ISTHKT(8+IIGLU1+IIGLU2)  =952
36181       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36182       JMOHKT(2,8+IIGLU1+IIGLU2)=0
36183       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36184       JDAHKT(2,8+IIGLU1+IIGLU2)=0
36185       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC2T)+
36186      * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36187       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC2T)+
36188      * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36189       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC2T)+
36190      * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36191       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC2T)+
36192      * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36193 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36194 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36195       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36196 C       IREJ=1
36197 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36198 C    *  ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
36199         IPCO=0
36200 C       RETURN
36201         GO TO 3466
36202       ENDIF
36203 C     PHKT(5,8)  =PHKK(5,NC2T)
36204       XMIST  =(PHKT(4,8+IIGLU1+IIGLU2)**2-
36205      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36206      *PHKT(1,8+IIGLU1+IIGLU2)**2)
36207       IF(XMIST.GT.0.D0)THEN
36208       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36209      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36210      *PHKT(1,8+IIGLU1+IIGLU2)**2)
36211       ELSE
36212 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36213         PHKT(5,5+IIGLU1)=0.D0
36214       ENDIF
36215       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
36216       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
36217       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
36218       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
36219       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
36220       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
36221       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
36222       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
36223       IDHKT(9+IIGLU1+IIGLU2)   =88888
36224       ISTHKT(9+IIGLU1+IIGLU2)  =95
36225       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36226       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36227       JDAHKT(1,9+IIGLU1+IIGLU2)=0
36228       JDAHKT(2,9+IIGLU1+IIGLU2)=0
36229 **NEW
36230 C     PHKT(1,9+IIGLU1+IIGLU2)
36231 C    * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36232 C     PHKT(2,9+IIGLU1+IIGLU2)
36233 C    * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36234 C     PHKT(3,9+IIGLU1+IIGLU2)
36235 C    * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36236 C     PHKT(4,9+IIGLU1+IIGLU2)
36237 C    * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36238       PHKT(1,9+IIGLU1+IIGLU2)
36239      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36240       PHKT(2,9+IIGLU1+IIGLU2)
36241      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36242       PHKT(3,9+IIGLU1+IIGLU2)
36243      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36244       PHKT(4,9+IIGLU1+IIGLU2)
36245      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36246 **
36247       XMIST
36248      * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36249      * -PHKT(2,9+IIGLU1+IIGLU2)**2
36250      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
36251       IF(XMIST.GT.0.D0)THEN
36252       PHKT(5,9+IIGLU1+IIGLU2)
36253      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36254      * -PHKT(2,9+IIGLU1+IIGLU2)**2
36255      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
36256       ELSE
36257 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36258         PHKT(5,5+IIGLU1)=0.D0
36259       ENDIF
36260       IF(IPIP.GE.2)THEN
36261 C     IF(NUMEV.EQ.-324)THEN
36262 C     WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36263 C    * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36264 C    *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36265 C     DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36266 C     WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
36267 C    * JDAHKT(1,IIG),
36268 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36269 C  91 CONTINUE
36270 C     WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36271 C    * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36272 C    *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36273 C    *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36274 C     WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36275 C    * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36276 C    *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36277 C    *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36278       ENDIF
36279       CHAMAL=CHAB1
36280       IF(IPIP.EQ.1)THEN
36281         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36282       ELSEIF(IPIP.EQ.2)THEN
36283         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36284       ENDIF
36285       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36286 C       IREJ=1
36287         IPCO=0
36288 C       RETURN
36289 C       WRITE(6,*)' MUSQBS1 jump back from chain 9',
36290 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
36291         GO TO 3466
36292       ENDIF
36293       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
36294       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
36295       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
36296       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
36297       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
36298       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
36299       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
36300       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
36301 C
36302       IPCO=0
36303       IGCOUN=9+IIGLU1+IIGLU2
36304        RETURN
36305        END
36306
36307 *$ CREATE MGSQBS2.FOR
36308 *COPY MGSQBS2
36309 C
36310 C
36311 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36312       SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36313      *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
36314 C
36315 C                  GSQBS-2 diagram (split target diquark)
36316 C
36317       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36318       SAVE
36319
36320       PARAMETER ( LINP = 10 ,
36321      &            LOUT = 6 ,
36322      &            LDAT = 9 )
36323
36324 * event history
36325
36326       PARAMETER (NMXHKK=200000)
36327
36328       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36329      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36330      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36331
36332 * extended event history
36333       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36334      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36335      &                IHIST(2,NMXHKK)
36336
36337 * Lorentz-parameters of the current interaction
36338       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36339      &                UMO,PPCM,EPROJ,PPROJ
36340
36341 * diquark-breaking mechanism
36342       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36343
36344 C
36345       PARAMETER (NTMHKK= 300)
36346       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36347      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36348      +(4,NTMHKK)
36349
36350 *KEEP,XSEADI.
36351       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36352      +SSMIMQ,VVMTHR
36353 *KEEP,DPRIN.
36354       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36355 C
36356 C                  GSQBS-2 diagram (split target diquark)
36357 C
36358 C
36359 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
36360 C     Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
36361 C
36362 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
36363 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36364 C
36365 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36366 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36367 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36368 C
36369 C
36370 C
36371 C       Put new chains into COMMON /HKKTMP/
36372 C
36373       IIGLU1=NC1T-NC1P-1
36374       IIGLU2=NC2T-NC2P-1
36375       IGCOUN=0
36376 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36377       CVQ=1.D0
36378       IREJ=0
36379 C     IF(IPIP.EQ.2)THEN
36380 C     WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
36381 C    *             'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
36382 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36383 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
36384 C     ENDIF
36385 C
36386 C
36387 C
36388 C     determine x-values of NC1T diquark
36389       XDIQT=PHKK(4,NC1T)*2.D0/UMO
36390       XVQP=PHKK(4,NC1P)*2.D0/UMO
36391 C
36392 C     determine x-values of sea quark pair
36393 C
36394       IPCO=1
36395       ICOU=0
36396  2234 CONTINUE
36397       ICOU=ICOU+1
36398       IF(ICOU.GE.500)THEN
36399         IREJ=1
36400         IF(ISQ.EQ.3)IREJ=3
36401         IF(IPCO.GE.3)
36402      &     WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
36403         IPCO=0
36404         RETURN
36405       ENDIF
36406       IF(IPCO.GE.3)
36407      &     WRITE(LOUT,*)'MGSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
36408      * UMO, XDIQT,XVQP
36409       XSQ=0.D0
36410       XSAQ=0.D0
36411 **NEW
36412 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
36413       IF (IPIP.EQ.1) THEN
36414          XQMAX  = XDIQT/2.0D0
36415          XAQMAX = 2.D0*XVQP/3.0D0
36416       ELSE
36417          XQMAX  = 2.D0*XVQP/3.0D0
36418          XAQMAX = XDIQT/2.0D0
36419       ENDIF
36420       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
36421       ISAQ = 6+ISQ
36422 C     write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
36423 **
36424         IF(IPCO.GE.3)
36425      &     WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36426       IF(IREJ.GE.1)THEN
36427         IF(IPCO.GE.3)
36428      &     WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36429         IPCO=0
36430         RETURN
36431       ENDIF
36432       IF(IPIP.EQ.1)THEN
36433         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36434       ELSEIF(IPIP.EQ.2)THEN
36435         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36436       ENDIF
36437       IF(IPCO.GE.3)THEN
36438         WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
36439      &  XDIQT,XVQP,XSQ,XSAQ
36440       ENDIF
36441 C
36442 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
36443 C
36444 C     XSQ=0.D0
36445       IF(IPIP.EQ.1)THEN
36446         XDIQT=XDIQT-XSQ
36447         XVQP =XVQP -XSAQ
36448       ELSEIF(IPIP.EQ.2)THEN
36449         XDIQT=XDIQT-XSAQ
36450         XVQP =XVQP -XSQ
36451       ENDIF
36452       IF(IPCO.GE.3)
36453      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
36454 C
36455 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36456 C
36457       XVTHRO=CVQ/UMO
36458       IVTHR=0
36459  3466 CONTINUE
36460       IF(IVTHR.EQ.10)THEN
36461         IREJ=1
36462         IF(ISQ.EQ.3)IREJ=3
36463         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
36464         IPCO=0
36465         RETURN
36466       ENDIF
36467       IVTHR=IVTHR+1
36468       XVTHR=XVTHRO/(201-IVTHR)
36469       UNOPRV=UNON
36470  380  CONTINUE
36471       IF(XVTHR.GT.0.66D0*XDIQT)THEN
36472         IREJ=1
36473         IF(ISQ.EQ.3)IREJ=3
36474         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR  large',
36475      *  XVTHR
36476         IPCO=0
36477         RETURN
36478       ENDIF
36479       IF(DT_RNDM(V).LT.0.5D0)THEN
36480         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36481         XVTQII=XDIQT-XVTQI
36482       ELSE
36483         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36484         XVTQI=XDIQT-XVTQII
36485       ENDIF
36486       IF(IPCO.GE.3)THEN
36487         WRITE(LOUT,'(A,2E12.4)')'  MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
36488       ENDIF
36489 C
36490 C     Prepare 4 momenta of new chains and chain ends
36491 C
36492 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36493 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36494 C    +(4,NTMHKK)
36495 C
36496 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36497 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36498 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36499 C
36500 C     SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36501 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
36502 C
36503       IF(IPIP.EQ.1)THEN
36504         XSQ1=XSQ
36505         XSAQ1=XSAQ
36506         ISQ1=ISQ
36507         ISAQ1=ISAQ
36508       ELSEIF(IPIP.EQ.2)THEN
36509         XSQ1=XSAQ
36510         XSAQ1=XSQ
36511         ISQ1=ISAQ
36512         ISAQ1=ISQ
36513       ENDIF
36514       KK11=IP21
36515 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36516       KK21=IPP11
36517       KK22=IPP12
36518       XGIVE=0.D0
36519       IF(IPIP.EQ.1)THEN
36520         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
36521       ELSEIF(IPIP.EQ.2)THEN
36522         IDHKT(4+IIGLU1)   =ISAQ1
36523       ENDIF
36524       ISTHKT(4+IIGLU1)  =961
36525       JMOHKT(1,4+IIGLU1)=NC1P
36526       JMOHKT(2,4+IIGLU1)=0
36527       JDAHKT(1,4+IIGLU1)=6+IIGLU1
36528       JDAHKT(2,4+IIGLU1)=0
36529 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36530       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36531       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36532       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36533       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36534 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
36535       XXMIST=(PHKT(4,4+IIGLU1)**2-
36536      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36537      *PHKT(1,4+IIGLU1)**2)
36538       IF(XXMIST.GT.0.D0)THEN
36539         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
36540       ELSE
36541         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36542         XXMIST=ABS(XXMIST)
36543         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
36544       ENDIF
36545       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
36546       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
36547       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
36548       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
36549       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
36550       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
36551       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
36552       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
36553       IDHKT(5+IIGLU1)   =IP22
36554       ISTHKT(5+IIGLU1)  =962
36555       JMOHKT(1,5+IIGLU1)=NC1T
36556       JMOHKT(2,5+IIGLU1)=0
36557       JDAHKT(1,5+IIGLU1)=6+IIGLU1
36558       JDAHKT(2,5+IIGLU1)=0
36559       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36560       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36561       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36562       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36563 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
36564       XXMIST=(PHKT(4,5+IIGLU1)**2-
36565      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36566      *PHKT(1,5+IIGLU1)**2)
36567       IF(XXMIST.GT.0.D0)THEN
36568         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
36569       ELSE
36570         WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
36571         XXMIST=ABS(XXMIST)
36572         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
36573       ENDIF
36574       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
36575       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
36576       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
36577       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
36578       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
36579       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
36580       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
36581       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
36582       IDHKT(6+IIGLU1)   =88888
36583       ISTHKT(6+IIGLU1)  =96
36584       JMOHKT(1,6+IIGLU1)=4+IIGLU1
36585       JMOHKT(2,6+IIGLU1)=5+IIGLU1
36586       JDAHKT(1,6+IIGLU1)=0
36587       JDAHKT(2,6+IIGLU1)=0
36588       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36589       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36590       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36591       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36592       PHKT(5,6+IIGLU1)
36593      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36594      *            -PHKT(3,6+IIGLU1)**2)
36595       CHAMAL=CHAM1
36596       IF(IPIP.EQ.1)THEN
36597         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36598       ELSEIF(IPIP.EQ.2)THEN
36599         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36600       ENDIF
36601 C---------------------------------------------------
36602       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36603         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
36604 C                    we drop chain 6 and give the energy to chain 3
36605           IDHKT(6+IIGLU1)=22888
36606           XGIVE=1.D0
36607 C         WRITE(6,*)' drop chain 6 xgive=1'
36608           GO TO 7788
36609         ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
36610 C                    we drop chain 6 and give the energy to chain 3
36611 C                    and change KK11 to IDHKT(5)
36612           IDHKT(6+IIGLU1)=22888
36613           XGIVE=1.D0
36614 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
36615           KK11=IDHKT(5+IIGLU1)
36616           GO TO 7788
36617         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
36618 C                    we drop chain 6 and give the energy to chain 3
36619 C                    and change KK21 to IDHKT(5+IIGLU1)
36620 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36621           IDHKT(6+IIGLU1)=22888
36622           XGIVE=1.D0
36623 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
36624           KK21=IDHKT(5+IIGLU1)
36625           GO TO 7788
36626         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
36627 C                    we drop chain 6 and give the energy to chain 3
36628 C                    and change KK22 to IDHKT(5)
36629 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36630           IDHKT(6+IIGLU1)=22888
36631           XGIVE=1.D0
36632 C          WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
36633           KK22=IDHKT(5+IIGLU1)
36634           GO TO 7788
36635         ENDIF
36636 C       IREJ=1
36637         IPCO=0
36638 C       RETURN
36639         GO TO 3466
36640       ENDIF
36641  7788 CONTINUE
36642 C---------------------------------------------------
36643       IF(IPIP.GE.3)THEN
36644       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36645      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36646      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36647       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36648      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36649      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36650       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36651      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36652      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36653       ENDIF
36654       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
36655       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
36656       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
36657       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
36658       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
36659       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
36660       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
36661       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
36662 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36663       IF(IPIP.EQ.1)THEN
36664         IDHKT(1)   =1000*KK21+100*KK22+3
36665         IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
36666         IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
36667         IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
36668       ELSEIF(IPIP.EQ.2)THEN
36669         IDHKT(1)   =1000*KK21+100*KK22-3
36670         IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
36671         IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
36672         IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
36673       ENDIF
36674       ISTHKT(1)  =961
36675       JMOHKT(1,1)=NC2P
36676       JMOHKT(2,1)=0
36677       JDAHKT(1,1)=3+IIGLU1
36678       JDAHKT(2,1)=0
36679 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36680       PHKT(1,1)  =PHKK(1,NC2P)
36681      *+XGIVE*PHKT(1,4+IIGLU1)
36682       PHKT(2,1)  =PHKK(2,NC2P)
36683      *+XGIVE*PHKT(2,4+IIGLU1)
36684       PHKT(3,1)  =PHKK(3,NC2P)
36685      *+XGIVE*PHKT(3,4+IIGLU1)
36686       PHKT(4,1)  =PHKK(4,NC2P)
36687      *+XGIVE*PHKT(4,4+IIGLU1)
36688 C     PHKT(5,1)  =PHKK(5,NC2P)
36689       XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36690      *PHKT(1,1)**2
36691       IF(XXMIST.GT.0.D0)THEN
36692         PHKT(5,1)  =SQRT(XXMIST)
36693       ELSE
36694         WRITE(LOUT,*)'MGSQBS2',XXMIST
36695         XXMIST=ABS(XXMIST)
36696         PHKT(5,1)  =SQRT(XXMIST)
36697       ENDIF
36698       VHKT(1,1)  =VHKK(1,NC2P)
36699       VHKT(2,1)  =VHKK(2,NC2P)
36700       VHKT(3,1)  =VHKK(3,NC2P)
36701       VHKT(4,1)  =VHKK(4,NC2P)
36702       WHKT(1,1)  =WHKK(1,NC2P)
36703       WHKT(2,1)  =WHKK(2,NC2P)
36704       WHKT(3,1)  =WHKK(3,NC2P)
36705       WHKT(4,1)  =WHKK(4,NC2P)
36706 C     Add here IIGLU1 gluons to this chaina
36707       PG1=0.D0
36708       PG2=0.D0
36709       PG3=0.D0
36710       PG4=0.D0
36711       IF(IIGLU1.GE.1)THEN
36712       JJG=NC1P
36713       DO 61 IIG=2,2+IIGLU1-1
36714         KKG=JJG+IIG-1
36715         IDHKT(IIG)   =IDHKK(KKG)
36716         ISTHKT(IIG)  =921
36717         JMOHKT(1,IIG)=KKG
36718         JMOHKT(2,IIG)=0
36719         JDAHKT(1,IIG)=3+IIGLU1
36720         JDAHKT(2,IIG)=0
36721         PHKT(1,IIG)=PHKK(1,KKG)
36722         PG1=PG1+ PHKT(1,IIG)
36723         PHKT(2,IIG)=PHKK(2,KKG)
36724         PG2=PG2+ PHKT(2,IIG)
36725         PHKT(3,IIG)=PHKK(3,KKG)
36726         PG3=PG3+ PHKT(3,IIG)
36727         PHKT(4,IIG)=PHKK(4,KKG)
36728         PG4=PG4+ PHKT(4,IIG)
36729         PHKT(5,IIG)=PHKK(5,KKG)
36730         VHKT(1,IIG)  =VHKK(1,KKG)
36731         VHKT(2,IIG)  =VHKK(2,KKG)
36732         VHKT(3,IIG)  =VHKK(3,KKG)
36733         VHKT(4,IIG)  =VHKK(4,KKG)
36734         WHKT(1,IIG)  =WHKK(1,KKG)
36735         WHKT(2,IIG)  =WHKK(2,KKG)
36736         WHKT(3,IIG)  =WHKK(3,KKG)
36737         WHKT(4,IIG)  =WHKK(4,KKG)
36738    61 CONTINUE
36739       ENDIF
36740 C     IDHKT(2)   =IP21
36741       IDHKT(2+IIGLU1)   =KK11
36742       ISTHKT(2+IIGLU1)  =962
36743       JMOHKT(1,2+IIGLU1)=NC1T
36744       JMOHKT(2,2+IIGLU1)=0
36745       JDAHKT(1,2+IIGLU1)=3+IIGLU1
36746       JDAHKT(2,2+IIGLU1)=0
36747       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
36748 C    * +0.5D0*PHKK(1,NC2T)
36749      *+XGIVE*PHKT(1,5+IIGLU1)
36750       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
36751 C    *+0.5D0*PHKK(2,NC2T)
36752      *+XGIVE*PHKT(2,5+IIGLU1)
36753       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
36754 C    *+0.5D0*PHKK(3,NC2T)
36755      *+XGIVE*PHKT(3,5+IIGLU1)
36756       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
36757 C    *+0.5D0*PHKK(4,NC2T)
36758      *+XGIVE*PHKT(4,5+IIGLU1)
36759 C     PHKT(5,2)  =PHKK(5,NC1T)
36760       XXMIST=(PHKT(4,2+IIGLU1)**2-
36761      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36762      *PHKT(1,2+IIGLU1)**2)
36763       IF(XXMIST.GT.0.D0)THEN
36764         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
36765       ELSE
36766         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36767         XXMIST=ABS(XXMIST)
36768         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
36769       ENDIF
36770       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
36771       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
36772       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
36773       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
36774       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
36775       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
36776       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
36777       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
36778       IDHKT(3+IIGLU1)   =88888
36779       ISTHKT(3+IIGLU1)  =96
36780       JMOHKT(1,3+IIGLU1)=1
36781       JMOHKT(2,3+IIGLU1)=2+IIGLU1
36782       JDAHKT(1,3+IIGLU1)=0
36783       JDAHKT(2,3+IIGLU1)=0
36784       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
36785       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
36786       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
36787       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
36788       PHKT(5,3+IIGLU1)
36789      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
36790      *            -PHKT(3,3+IIGLU1)**2)
36791       IF(IPIP.EQ.3)THEN
36792       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
36793      * JDAHKT(1,1),
36794      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
36795       DO 71 IIG=2,2+IIGLU1-1
36796       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36797      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
36798      * JDAHKT(1,IIG),
36799      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36800    71 CONTINUE
36801       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
36802      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
36803      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
36804       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
36805      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
36806      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
36807       ENDIF
36808       CHAMAL=CHAB1
36809       IF(IPIP.EQ.1)THEN
36810         IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
36811       ELSEIF(IPIP.EQ.2)THEN
36812         IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
36813       ENDIF
36814       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
36815 C       IREJ=1
36816         IPCO=0
36817 C       RETURN
36818         GO TO 3466
36819       ENDIF
36820       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
36821       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
36822       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
36823       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
36824       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
36825       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
36826       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
36827       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
36828 C     IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+1
36829       IDHKT(7+IIGLU1)   =IP1
36830       ISTHKT(7+IIGLU1)  =961
36831       JMOHKT(1,7+IIGLU1)=NC1P
36832       JMOHKT(2,7+IIGLU1)=0
36833       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36834       JDAHKT(2,7+IIGLU1)=0
36835       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36836       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36837       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36838       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36839 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
36840       XXMIST=(PHKT(4,7+IIGLU1)**2-
36841      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36842      *PHKT(1,7+IIGLU1)**2)
36843       IF(XXMIST.GT.0.D0)THEN
36844         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
36845       ELSE
36846         WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
36847         XXMIST=ABS(XXMIST)
36848         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
36849       ENDIF
36850       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
36851       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
36852       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
36853       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
36854       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
36855       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
36856       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
36857       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
36858 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
36859 C     Insert here the IIGLU2 gluons
36860       PG1=0.D0
36861       PG2=0.D0
36862       PG3=0.D0
36863       PG4=0.D0
36864       IF(IIGLU2.GE.1)THEN
36865       JJG=NC2P
36866       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36867         KKG=JJG+IIG-7-IIGLU1
36868         IDHKT(IIG)   =IDHKK(KKG)
36869         ISTHKT(IIG)  =921
36870         JMOHKT(1,IIG)=KKG
36871         JMOHKT(2,IIG)=0
36872         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36873         JDAHKT(2,IIG)=0
36874         PHKT(1,IIG)=PHKK(1,KKG)
36875         PG1=PG1+ PHKT(1,IIG)
36876         PHKT(2,IIG)=PHKK(2,KKG)
36877         PG2=PG2+ PHKT(2,IIG)
36878         PHKT(3,IIG)=PHKK(3,KKG)
36879         PG3=PG3+ PHKT(3,IIG)
36880         PHKT(4,IIG)=PHKK(4,KKG)
36881         PG4=PG4+ PHKT(4,IIG)
36882         PHKT(5,IIG)=PHKK(5,KKG)
36883         VHKT(1,IIG)  =VHKK(1,KKG)
36884         VHKT(2,IIG)  =VHKK(2,KKG)
36885         VHKT(3,IIG)  =VHKK(3,KKG)
36886         VHKT(4,IIG)  =VHKK(4,KKG)
36887         WHKT(1,IIG)  =WHKK(1,KKG)
36888         WHKT(2,IIG)  =WHKK(2,KKG)
36889         WHKT(3,IIG)  =WHKK(3,KKG)
36890         WHKT(4,IIG)  =WHKK(4,KKG)
36891    81 CONTINUE
36892       ENDIF
36893       IF(IPIP.EQ.1)THEN
36894         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
36895         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36896         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36897         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36898       ELSEIF(IPIP.EQ.2)THEN
36899 **NEW
36900 C       IDHKT(8)   =1000*IPP2+100*(-ISQ1+6)-3
36901         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
36902 **
36903         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36904         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36905         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36906       ENDIF
36907       ISTHKT(8+IIGLU1+IIGLU2)  =962
36908       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36909       JMOHKT(2,8+IIGLU1+IIGLU2)=0
36910       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36911       JDAHKT(2,8+IIGLU1+IIGLU2)=0
36912 C     PHKT(1,8)  =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
36913 C     PHKT(2,8)  =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
36914 C     PHKT(3,8)  =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
36915 C     PHKT(4,8)  =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
36916       PHKT(1,8+IIGLU1+IIGLU2)  =
36917      * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36918       PHKT(2,8+IIGLU1+IIGLU2)  =
36919      * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36920       PHKT(3,8+IIGLU1+IIGLU2)  =
36921      * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36922       PHKT(4,8+IIGLU1+IIGLU2)  =
36923      * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36924 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36925 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36926       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36927 C       IREJ=1
36928 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36929         IPCO=0
36930 C       RETURN
36931         GO TO 3466
36932       ENDIF
36933 C     PHKT(5,8)  =PHKK(5,NC2T)
36934       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36935      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36936      *PHKT(1,8+IIGLU1+IIGLU2)**2)
36937       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
36938       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
36939       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
36940       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
36941       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
36942       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
36943       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
36944       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
36945       IDHKT(9+IIGLU1+IIGLU2)   =88888
36946       ISTHKT(9+IIGLU1+IIGLU2)  =96
36947       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36948       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36949       JDAHKT(1,9+IIGLU1+IIGLU2)=0
36950       JDAHKT(2,9+IIGLU1+IIGLU2)=0
36951       PHKT(1,9+IIGLU1+IIGLU2)
36952      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36953       PHKT(2,9+IIGLU1+IIGLU2)
36954      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36955       PHKT(3,9+IIGLU1+IIGLU2)
36956      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36957       PHKT(4,9+IIGLU1+IIGLU2)
36958      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36959       PHKT(5,9+IIGLU1+IIGLU2)
36960      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
36961      * PHKT(2,9+IIGLU1+IIGLU2)**2
36962      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
36963       IF(IPIP.GE.3)THEN
36964       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36965      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36966      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36967       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36968       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36969      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
36970      * JDAHKT(1,IIG),
36971      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36972    91 CONTINUE
36973       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36974      * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36975      *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36976      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36977       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36978      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36979      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36980      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36981       ENDIF
36982       CHAMAL=CHAB1
36983       IF(IPIP.EQ.1)THEN
36984         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36985       ELSEIF(IPIP.EQ.2)THEN
36986         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36987       ENDIF
36988       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36989 C       IREJ=1
36990         IPCO=0
36991 C       RETURN
36992         GO TO 3466
36993       ENDIF
36994       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
36995       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
36996       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
36997       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
36998       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
36999       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
37000       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
37001       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
37002 C
37003       IPCO=0
37004       IGCOUN=9+IIGLU1+IIGLU2
37005        RETURN
37006        END
37007
37008 *$ CREATE MUSQBS1.FOR
37009 *COPY MUSQBS1
37010 C
37011 C
37012 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37013       SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37014      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
37015 C
37016 C                  USQBS-1 diagram (split projectile diquark)
37017 C
37018       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37019       SAVE
37020
37021       PARAMETER ( LINP = 10 ,
37022      &            LOUT = 6 ,
37023      &            LDAT = 9 )
37024
37025 * event history
37026
37027       PARAMETER (NMXHKK=200000)
37028
37029       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37030      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37031      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37032
37033 * extended event history
37034       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37035      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37036      &                IHIST(2,NMXHKK)
37037
37038 * Lorentz-parameters of the current interaction
37039       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37040      &                UMO,PPCM,EPROJ,PPROJ
37041
37042 * diquark-breaking mechanism
37043       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37044
37045 C
37046       PARAMETER (NTMHKK= 300)
37047       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37048      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37049      +(4,NTMHKK)
37050 *KEEP,XSEADI.
37051       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37052      +SSMIMQ,VVMTHR
37053 *KEEP,DPRIN.
37054       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37055       COMMON /EVFLAG/ NUMEV
37056 C
37057 C                  USQBS-1 diagram (split projectile diquark)
37058 C
37059 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37060 C     Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
37061 C
37062 C     Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
37063 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37064 C
37065 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37066 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37067 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37068 C
37069 C       Put new chains into COMMON /HKKTMP/
37070 C
37071       IIGLU1=NC1T-NC1P-1
37072       IIGLU2=NC2T-NC2P-1
37073       IGCOUN=0
37074 C     WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
37075       CVQ=1.D0
37076       IREJ=0
37077       IF(IPIP.EQ.3)THEN
37078 C     IF(NUMEV.EQ.-324)THEN
37079       WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37080      *             ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
37081      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37082      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
37083       ENDIF
37084 C
37085 C
37086 C
37087 C     determine x-values of NC1P diquark
37088       XDIQP=PHKK(4,NC1P)*2.D0/UMO
37089       XVQT=PHKK(4,NC1T)*2.D0/UMO
37090 C
37091 C     determine x-values of sea quark pair
37092 C
37093       IPCO=1
37094       ICOU=0
37095  2234 CONTINUE
37096       ICOU=ICOU+1
37097       IF(ICOU.GE.500)THEN
37098         IREJ=1
37099         IF(ISQ.EQ.3)IREJ=3
37100         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
37101         IPCO=0
37102         RETURN
37103       ENDIF
37104       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
37105      * UMO, XDIQP,XVQT
37106       XSQ=0.D0
37107       XSAQ=0.D0
37108 **NEW
37109 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37110       IF (IPIP.EQ.1) THEN
37111          XQMAX  = XDIQP/2.0D0
37112          XAQMAX = 2.D0*XVQT/3.0D0
37113       ELSE
37114          XQMAX  = 2.D0*XVQT/3.0D0
37115          XAQMAX = XDIQP/2.0D0
37116       ENDIF
37117       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37118       ISAQ = 6+ISQ
37119 C     write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37120 **
37121       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37122       IF(IREJ.GE.1)THEN
37123         IF(IPCO.GE.3)
37124      &     WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37125         IPCO=0
37126         RETURN
37127       ENDIF
37128       IF(IPIP.EQ.1)THEN
37129         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37130       ELSEIF(IPIP.EQ.2)THEN
37131         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37132       ENDIF
37133       IF(IPCO.GE.3)THEN
37134         WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37135      &  XDIQP,XVQT,XSQ,XSAQ
37136       ENDIF
37137 C
37138 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
37139 C
37140 C     XSQ=0.D0
37141       IF(IPIP.EQ.1)THEN
37142         XDIQP=XDIQP-XSQ
37143         XVQT =XVQT -XSAQ
37144       ELSEIF(IPIP.EQ.2)THEN
37145         XDIQP=XDIQP-XSAQ
37146         XVQT =XVQT -XSQ
37147       ENDIF
37148       IF(IPCO.GE.3)
37149      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37150 C
37151 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37152 C
37153       XVTHRO=CVQ/UMO
37154       IVTHR=0
37155  3466 CONTINUE
37156       IF(IVTHR.EQ.10)THEN
37157         IREJ=1
37158         IF(ISQ.EQ.3)IREJ=3
37159         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
37160         IPCO=0
37161         RETURN
37162       ENDIF
37163       IVTHR=IVTHR+1
37164       XVTHR=XVTHRO/(201-IVTHR)
37165       UNOPRV=UNON
37166  380  CONTINUE
37167       IF(XVTHR.GT.0.66D0*XDIQP)THEN
37168         IREJ=1
37169         IF(ISQ.EQ.3)IREJ=3
37170         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR  large',
37171      *  XVTHR
37172         IPCO=0
37173         RETURN
37174       ENDIF
37175       IF(DT_RNDM(V).LT.0.5D0)THEN
37176         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37177         XVPQII=XDIQP-XVPQI
37178       ELSE
37179         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37180         XVPQI=XDIQP-XVPQII
37181       ENDIF
37182       IF(IPCO.GE.3)THEN
37183         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
37184       ENDIF
37185 C
37186 C     Prepare 4 momenta of new chains and chain ends
37187 C
37188 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37189 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37190 C    +(4,NTMHKK)
37191 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37192 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37193 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37194       IF(IPIP.EQ.1)THEN
37195         XSQ1=XSQ
37196         XSAQ1=XSAQ
37197         ISQ1=ISQ
37198         ISAQ1=ISAQ
37199       ELSEIF(IPIP.EQ.2)THEN
37200         XSQ1=XSAQ
37201         XSAQ1=XSQ
37202         ISQ1=ISAQ
37203         ISAQ1=ISQ
37204       ENDIF
37205       IDHKT(1)   =IP11
37206       ISTHKT(1)  =931
37207       JMOHKT(1,1)=NC1P
37208       JMOHKT(2,1)=0
37209       JDAHKT(1,1)=3+IIGLU1
37210       JDAHKT(2,1)=0
37211 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37212       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
37213       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
37214       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
37215       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
37216 C     PHKT(5,1)  =PHKK(5,NC1P)
37217       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37218      *PHKT(1,1)**2)
37219       IF(XMIST.GE.0.D0)THEN
37220       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37221      *PHKT(1,1)**2)
37222       ELSE
37223 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37224        PHKT(5,1)=0.D0
37225       ENDIF
37226       VHKT(1,1)  =VHKK(1,NC1P)
37227       VHKT(2,1)  =VHKK(2,NC1P)
37228       VHKT(3,1)  =VHKK(3,NC1P)
37229       VHKT(4,1)  =VHKK(4,NC1P)
37230       WHKT(1,1)  =WHKK(1,NC1P)
37231       WHKT(2,1)  =WHKK(2,NC1P)
37232       WHKT(3,1)  =WHKK(3,NC1P)
37233       WHKT(4,1)  =WHKK(4,NC1P)
37234 C     Add here IIGLU1 gluons to this chaina
37235       PG1=0.D0
37236       PG2=0.D0
37237       PG3=0.D0
37238       PG4=0.D0
37239       IF(IIGLU1.GE.1)THEN
37240       JJG=NC1P
37241       DO 61 IIG=2,2+IIGLU1-1
37242         KKG=JJG+IIG-1
37243         IDHKT(IIG)   =IDHKK(KKG)
37244         ISTHKT(IIG)  =921
37245         JMOHKT(1,IIG)=KKG
37246         JMOHKT(2,IIG)=0
37247         JDAHKT(1,IIG)=3+IIGLU1
37248         JDAHKT(2,IIG)=0
37249         PHKT(1,IIG)=PHKK(1,KKG)
37250         PG1=PG1+ PHKT(1,IIG)
37251         PHKT(2,IIG)=PHKK(2,KKG)
37252         PG2=PG2+ PHKT(2,IIG)
37253         PHKT(3,IIG)=PHKK(3,KKG)
37254         PG3=PG3+ PHKT(3,IIG)
37255         PHKT(4,IIG)=PHKK(4,KKG)
37256         PG4=PG4+ PHKT(4,IIG)
37257         PHKT(5,IIG)=PHKK(5,KKG)
37258         VHKT(1,IIG)  =VHKK(1,KKG)
37259         VHKT(2,IIG)  =VHKK(2,KKG)
37260         VHKT(3,IIG)  =VHKK(3,KKG)
37261         VHKT(4,IIG)  =VHKK(4,KKG)
37262         WHKT(1,IIG) =WHKK(1,KKG)
37263         WHKT(2,IIG) =WHKK(2,KKG)
37264         WHKT(3,IIG) =WHKK(3,KKG)
37265         WHKT(4,IIG) =WHKK(4,KKG)
37266    61 CONTINUE
37267       ENDIF
37268       IDHKT(2+IIGLU1)   =IPP2
37269       ISTHKT(2+IIGLU1)  =932
37270       JMOHKT(1,2+IIGLU1)=NC2T
37271       JMOHKT(2,2+IIGLU1)=0
37272       JDAHKT(1,2+IIGLU1)=3+IIGLU1
37273       JDAHKT(2,2+IIGLU1)=0
37274       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
37275       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
37276       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
37277       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
37278 C     PHKT(5,2+IIGLU1)  =PHKK(5,NC2T)
37279       XMIST=(PHKT(4,2+IIGLU1)**2-
37280      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37281      *PHKT(1,2+IIGLU1)**2)
37282       IF(XMIST.GT.0.D0)THEN
37283       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
37284      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37285      *PHKT(1,2+IIGLU1)**2)
37286       ELSE
37287 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37288         PHKT(5,2+IIGLU1)=0.D0
37289       ENDIF
37290       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
37291       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
37292       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
37293       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
37294       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
37295       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
37296       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
37297       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
37298       IDHKT(3+IIGLU1)   =88888
37299       ISTHKT(3+IIGLU1)  =94
37300       JMOHKT(1,3+IIGLU1)=1
37301       JMOHKT(2,3+IIGLU1)=2+IIGLU1
37302       JDAHKT(1,3+IIGLU1)=0
37303       JDAHKT(2,3+IIGLU1)=0
37304       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37305       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37306       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37307       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37308       XMIST
37309      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37310      *            -PHKT(3,3+IIGLU1)**2)
37311       IF(XMIST.GE.0.D0)THEN
37312       PHKT(5,3+IIGLU1)
37313      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37314      *            -PHKT(3,3+IIGLU1)**2)
37315       ELSE
37316 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37317        PHKT(5,1)=0.D0
37318       ENDIF
37319       IF(IPIP.GE.3)THEN
37320 C     IF(NUMEV.EQ.-324)THEN
37321       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
37322      * JMOHKT(2,1),JDAHKT(1,1),
37323      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37324       DO 71 IIG=2,2+IIGLU1-1
37325       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37326      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
37327      * JDAHKT(1,IIG),
37328      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37329    71 CONTINUE
37330       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37331      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37332      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37333       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37334      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37335      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37336       ENDIF
37337       CHAMAL=CHAM1
37338       IF(IPIP.EQ.1)THEN
37339         IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
37340       ELSEIF(IPIP.EQ.2)THEN
37341         IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
37342       ENDIF
37343       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37344 C       IREJ=1
37345         IPCO=0
37346 C       RETURN
37347 C       WRITE(6,*)' MUSQBS1 jump back from chain 3'
37348         GO TO 3466
37349       ENDIF
37350       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
37351       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
37352       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
37353       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
37354       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
37355       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
37356       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
37357       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
37358       IDHKT(4+IIGLU1)   =IP12
37359       ISTHKT(4+IIGLU1)  =931
37360       JMOHKT(1,4+IIGLU1)=NC1P
37361       JMOHKT(2,4+IIGLU1)=0
37362       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37363       JDAHKT(2,4+IIGLU1)=0
37364 C   create  chain   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37365       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37366       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37367       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37368       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37369 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37370       XMIST  =(PHKT(4,4+IIGLU1)**2-
37371      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37372      *PHKT(1,4+IIGLU1)**2)
37373       IF(XMIST.GT.0.D0)THEN
37374       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
37375      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37376      *PHKT(1,4+IIGLU1)**2)
37377       ELSE
37378 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37379         PHKT(5,4+IIGLU1)=0.D0
37380       ENDIF
37381       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37382       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37383       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37384       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37385       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37386       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37387       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37388       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37389       IF(IPIP.EQ.1)THEN
37390         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
37391       ELSEIF(IPIP.EQ.2)THEN
37392         IDHKT(5+IIGLU1)   =ISAQ1
37393       ENDIF
37394       ISTHKT(5+IIGLU1)  =932
37395       JMOHKT(1,5+IIGLU1)=NC1T
37396       JMOHKT(2,5+IIGLU1)=0
37397       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37398       JDAHKT(2,5+IIGLU1)=0
37399       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37400       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37401       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37402       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37403 C     IF( PHKT(4,5).EQ.0.D0)THEN
37404 C       IREJ=1
37405 CIPCO=0
37406 CRETURN
37407 C     ENDIF
37408 C     PHKT(5,5)  =PHKK(5,NC1T)
37409       XMIST=(PHKT(4,5+IIGLU1)**2-
37410      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37411      *PHKT(1,5+IIGLU1)**2)
37412       IF(XMIST.GT.0.D0)THEN
37413       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
37414      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37415      *PHKT(1,5+IIGLU1)**2)
37416       ELSE
37417 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37418         PHKT(5,5+IIGLU1)=0.D0
37419       ENDIF
37420       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37421       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37422       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37423       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37424       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37425       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37426       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37427       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37428       IDHKT(6+IIGLU1)   =88888
37429       ISTHKT(6+IIGLU1)  =94
37430       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37431       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37432       JDAHKT(1,6+IIGLU1)=0
37433       JDAHKT(2,6+IIGLU1)=0
37434       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37435       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37436       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37437       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37438       XMIST
37439      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37440      *            -PHKT(3,6+IIGLU1)**2)
37441       IF(XMIST.GE.0.D0)THEN
37442       PHKT(5,6+IIGLU1)
37443      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37444      *            -PHKT(3,6+IIGLU1)**2)
37445       ELSE
37446 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37447        PHKT(5,1)=0.D0
37448       ENDIF
37449 C     IF(IPIP.EQ.3)THEN
37450       CHAMAL=CHAM1
37451       IF(IPIP.EQ.1)THEN
37452         IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37453       ELSEIF(IPIP.EQ.2)THEN
37454         IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37455       ENDIF
37456       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37457 C       IREJ=1
37458         IPCO=0
37459 C       RETURN
37460 C       WRITE(6,*)' MGSQBS1 jump back from chain 6',
37461 C    &  CHAMAL,PHKT(5,6+IIGLU1)
37462         GO TO 3466
37463       ENDIF
37464       IF(IPIP.GE.3)THEN
37465 C     IF(NUMEV.EQ.-324)THEN
37466       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37467      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37468      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37469       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37470      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37471      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37472       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37473      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37474      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37475       ENDIF
37476       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
37477       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
37478       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
37479       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
37480       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
37481       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
37482       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
37483       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
37484       IF(IPIP.EQ.1)THEN
37485         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+3
37486         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
37487         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
37488         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
37489       ELSEIF(IPIP.EQ.2)THEN
37490         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
37491         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
37492         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
37493         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
37494 C       WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
37495       ENDIF
37496       ISTHKT(7+IIGLU1)  =931
37497       JMOHKT(1,7+IIGLU1)=NC2P
37498       JMOHKT(2,7+IIGLU1)=0
37499       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37500       JDAHKT(2,7+IIGLU1)=0
37501 C    create chain     9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37502       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
37503       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
37504       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
37505       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
37506 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
37507 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
37508       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
37509 C       IREJ=1
37510 C       WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
37511         IPCO=0
37512 C       RETURN
37513         GO TO 3466
37514       ENDIF
37515 C     PHKT(5,7)  =PHKK(5,NC2P)
37516       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
37517      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37518      *PHKT(1,7+IIGLU1)**2)
37519       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
37520       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
37521       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
37522       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
37523       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
37524       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
37525       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
37526       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
37527 C     Insert here the IIGLU2 gluons
37528       PG1=0.D0
37529       PG2=0.D0
37530       PG3=0.D0
37531       PG4=0.D0
37532       IF(IIGLU2.GE.1)THEN
37533       JJG=NC2P
37534       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37535         KKG=JJG+IIG-7-IIGLU1
37536         IDHKT(IIG)   =IDHKK(KKG)
37537         ISTHKT(IIG)  =921
37538         JMOHKT(1,IIG)=KKG
37539         JMOHKT(2,IIG)=0
37540         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37541         JDAHKT(2,IIG)=0
37542         PHKT(1,IIG)=PHKK(1,KKG)
37543         PG1=PG1+ PHKT(1,IIG)
37544         PHKT(2,IIG)=PHKK(2,KKG)
37545         PG2=PG2+ PHKT(2,IIG)
37546         PHKT(3,IIG)=PHKK(3,KKG)
37547         PG3=PG3+ PHKT(3,IIG)
37548         PHKT(4,IIG)=PHKK(4,KKG)
37549         PG4=PG4+ PHKT(4,IIG)
37550         PHKT(5,IIG)=PHKK(5,KKG)
37551         VHKT(1,IIG)  =VHKK(1,KKG)
37552         VHKT(2,IIG)  =VHKK(2,KKG)
37553         VHKT(3,IIG)  =VHKK(3,KKG)
37554         VHKT(4,IIG)  =VHKK(4,KKG)
37555         WHKT(1,IIG)  =WHKK(1,KKG)
37556         WHKT(2,IIG) =WHKK(2,KKG)
37557         WHKT(3,IIG) =WHKK(3,KKG)
37558         WHKT(4,IIG) =WHKK(4,KKG)
37559    81 CONTINUE
37560       ENDIF
37561       IDHKT(8+IIGLU1+IIGLU2)   =IP2
37562       ISTHKT(8+IIGLU1+IIGLU2)  =932
37563       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
37564       JMOHKT(2,8+IIGLU1+IIGLU2)=0
37565       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37566       JDAHKT(2,8+IIGLU1+IIGLU2)=0
37567       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
37568       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
37569       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
37570       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
37571 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
37572       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
37573      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37574      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37575       IF(XMIST.GT.0.D0)THEN
37576       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37577      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37578      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37579       ELSE
37580 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37581         PHKT(5,8+IIGLU1+IIGLU2)=0.D0
37582       ENDIF
37583       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
37584       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
37585       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
37586       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
37587       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
37588       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
37589       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
37590       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
37591       IDHKT(9+IIGLU1+IIGLU2)   =88888
37592       ISTHKT(9+IIGLU1+IIGLU2)  =94
37593       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37594       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37595       JDAHKT(1,9+IIGLU1+IIGLU2)=0
37596       JDAHKT(2,9+IIGLU1+IIGLU2)=0
37597       PHKT(1,9+IIGLU1+IIGLU2)
37598      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37599       PHKT(2,9+IIGLU1+IIGLU2)
37600      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37601       PHKT(3,9+IIGLU1+IIGLU2)
37602      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37603       PHKT(4,9+IIGLU1+IIGLU2)
37604      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37605       XMIST
37606      *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37607      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37608      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37609       IF(XMIST.GE.0.D0)THEN
37610       PHKT(5,9+IIGLU1+IIGLU2)
37611      *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37612      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37613      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37614       ELSE
37615 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37616        PHKT(5,1)=0.D0
37617       ENDIF
37618       IF(IPIP.GE.3)THEN
37619 C     IF(NUMEV.EQ.-324)THEN
37620       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37621      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37622      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37623       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37624       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37625      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
37626      * JDAHKT(1,IIG),
37627      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37628    91 CONTINUE
37629       WRITE(LOUT,*)8+IIGLU1+IIGLU2,
37630      * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
37631      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
37632      *JDAHKT(1,8+IIGLU1+IIGLU2),
37633      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37634       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37635      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37636      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37637      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37638       ENDIF
37639       CHAMAL=CHAB1
37640       IF(IPIP.EQ.1)THEN
37641         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37642       ELSEIF(IPIP.EQ.2)THEN
37643         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37644       ENDIF
37645       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37646 C       IREJ=1
37647         IPCO=0
37648 C       RETURN
37649 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
37650 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37651         GO TO 3466
37652       ENDIF
37653       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
37654       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
37655       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
37656       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
37657       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
37658       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
37659       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
37660       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
37661 C
37662       IPCO=0
37663       IGCOUN=9+IIGLU1+IIGLU2
37664        RETURN
37665        END
37666
37667 *$ CREATE MGSQBS1.FOR
37668 *COPY MGSQBS1
37669 C
37670 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37671       SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37672      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
37673 C
37674 C                  GSQBS-1 diagram (split projectile diquark)
37675 C
37676       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37677       SAVE
37678
37679       PARAMETER ( LINP = 10 ,
37680      &            LOUT = 6 ,
37681      &            LDAT = 9 )
37682
37683 * event history
37684
37685       PARAMETER (NMXHKK=200000)
37686
37687       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37688      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37689      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37690
37691 * extended event history
37692       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37693      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37694      &                IHIST(2,NMXHKK)
37695
37696 * Lorentz-parameters of the current interaction
37697       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37698      &                UMO,PPCM,EPROJ,PPROJ
37699
37700 * diquark-breaking mechanism
37701       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37702
37703 C
37704       PARAMETER (NTMHKK= 300)
37705       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37706      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37707      +(4,NTMHKK)
37708 *KEEP,XSEADI.
37709       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37710      +SSMIMQ,VVMTHR
37711 *KEEP,DPRIN.
37712       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37713 C
37714 C                  GSQBS-1 diagram (split projectile diquark)
37715 C
37716 C
37717 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37718 C     Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
37719 C
37720 C     Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
37721 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37722 C
37723 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37724 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37725 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37726 C
37727 C       Put new chains into COMMON /HKKTMP/
37728 C
37729       IIGLU1=NC1T-NC1P-1
37730       IIGLU2=NC2T-NC2P-1
37731       IGCOUN=0
37732 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37733       CVQ=1.D0
37734       NNNC1=IDHKK(NC1)/1000
37735       MMMC1=IDHKK(NC1)-NNNC1*1000
37736       KKKC1=ISTHKK(NC1)
37737       NNNC2=IDHKK(NC2)/1000
37738       MMMC2=IDHKK(NC2)-NNNC2*1000
37739       KKKC2=ISTHKK(NC2)
37740       IREJ=0
37741       IF(IPIP.EQ.3)THEN
37742       WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37743      *             ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
37744      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37745      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
37746       ENDIF
37747 C
37748 C
37749 C
37750 C     determine x-values of NC1P diquark
37751       XDIQP=PHKK(4,NC1P)*2.D0/UMO
37752       XVQT=PHKK(4,NC1T)*2.D0/UMO
37753 C
37754 C     determine x-values of sea quark pair
37755 C
37756       IPCO=1
37757       ICOU=0
37758  2234 CONTINUE
37759       ICOU=ICOU+1
37760       IF(ICOU.GE.500)THEN
37761         IREJ=1
37762         IF(ISQ.EQ.3)IREJ=3
37763         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
37764       IPCO=0
37765         RETURN
37766       ENDIF
37767       IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
37768      * UMO, XDIQP,XVQT
37769       XSQ=0.D0
37770       XSAQ=0.D0
37771 **NEW
37772 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37773       IF (IPIP.EQ.1) THEN
37774          XQMAX  = XDIQP/2.0D0
37775          XAQMAX = 2.D0*XVQT/3.0D0
37776       ELSE
37777          XQMAX  = 2.D0*XVQT/3.0D0
37778          XAQMAX = XDIQP/2.0D0
37779       ENDIF
37780       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37781       ISAQ = 6+ISQ
37782 C     write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37783 **
37784         IF(IPCO.GE.3)
37785      &     WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37786       IF(IREJ.GE.1)THEN
37787         IF(IPCO.GE.3)
37788      &     WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37789       IPCO=0
37790         RETURN
37791       ENDIF
37792       IF(IPIP.EQ.1)THEN
37793         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37794       ELSEIF(IPIP.EQ.2)THEN
37795         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37796       ENDIF
37797       IF(IPCO.GE.3)THEN
37798         WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37799      &  XDIQP,XVQT,XSQ,XSAQ
37800       ENDIF
37801 C
37802 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
37803 C
37804 C     XSQ=0.D0
37805       IF(IPIP.EQ.1)THEN
37806         XDIQP=XDIQP-XSQ
37807 **NEW
37808 C       IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
37809 **
37810         XVQT =XVQT -XSAQ
37811       ELSEIF(IPIP.EQ.2)THEN
37812         XDIQP=XDIQP-XSAQ
37813         XVQT =XVQT -XSQ
37814       ENDIF
37815       IF(IPCO.GE.3)
37816      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37817 C
37818 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37819 C
37820       XVTHRO=CVQ/UMO
37821       IVTHR=0
37822  3466 CONTINUE
37823       IF(IVTHR.EQ.10)THEN
37824         IREJ=1
37825         IF(ISQ.EQ.3)IREJ=3
37826         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
37827       IPCO=0
37828         RETURN
37829       ENDIF
37830       IVTHR=IVTHR+1
37831       XVTHR=XVTHRO/(201-IVTHR)
37832       UNOPRV=UNON
37833  380  CONTINUE
37834       IF(XVTHR.GT.0.66D0*XDIQP)THEN
37835         IREJ=1
37836         IF(ISQ.EQ.3)IREJ=3
37837         IF(IPCO.GE.3)
37838      &     WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR  large',
37839      *  XVTHR
37840       IPCO=0
37841         RETURN
37842       ENDIF
37843       IF(DT_RNDM(V).LT.0.5D0)THEN
37844         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37845         XVPQII=XDIQP-XVPQI
37846       ELSE
37847         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37848         XVPQI=XDIQP-XVPQII
37849       ENDIF
37850       IF(IPCO.GE.3)THEN
37851         WRITE(LOUT,'(A,4E12.4)')'  MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
37852      &  XVTHR,XDIQP,XVPQI,XVPQII
37853       ENDIF
37854 C
37855 C     Prepare 4 momenta of new chains and chain ends
37856 C
37857 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37858 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37859 C    +(4,NTMHKK)
37860 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37861 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37862 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37863       IF(IPIP.EQ.1)THEN
37864         XSQ1=XSQ
37865         XSAQ1=XSAQ
37866         ISQ1=ISQ
37867         ISAQ1=ISAQ
37868       ELSEIF(IPIP.EQ.2)THEN
37869         XSQ1=XSAQ
37870         XSAQ1=XSQ
37871         ISQ1=ISAQ
37872         ISAQ1=ISQ
37873       ENDIF
37874       KK11=IP11
37875 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
37876       KK21= IPP21
37877       KK22= IPP22
37878       XGIVE=0.D0
37879       IDHKT(4+IIGLU1)   =IP12
37880       ISTHKT(4+IIGLU1)  =921
37881       JMOHKT(1,4+IIGLU1)=NC1P
37882       JMOHKT(2,4+IIGLU1)=0
37883       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37884       JDAHKT(2,4+IIGLU1)=0
37885 **NEW
37886       IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
37887      &    (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
37888 **
37889       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37890       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37891       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37892       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37893 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37894       XXMIST=(PHKT(4,4+IIGLU1)**2-
37895      *              PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37896      *              PHKT(1,4+IIGLU1)**2)
37897       IF(XXMIST.GT.0.D0)THEN
37898         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37899       ELSE
37900         WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
37901         XXMIST=ABS(XXMIST)
37902         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37903       ENDIF
37904       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37905       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37906       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37907       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37908       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37909       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37910       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37911       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37912       IF(IPIP.EQ.1)THEN
37913         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
37914       ELSEIF(IPIP.EQ.2)THEN
37915         IDHKT(5+IIGLU1)   =ISAQ1
37916       ENDIF
37917       ISTHKT(5+IIGLU1)  =922
37918       JMOHKT(1,5+IIGLU1)=NC1T
37919       JMOHKT(2,5+IIGLU1)=0
37920       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37921       JDAHKT(2,5+IIGLU1)=0
37922 **NEW
37923       IF ((XSAQ1.LT.0.0D0).OR.(XVQT  .LT.0.0D0))
37924      &    WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
37925 **
37926       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37927       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37928       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37929       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37930 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
37931       XMIST=(PHKT(4,5+IIGLU1)**2-
37932      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37933      *PHKT(1,5+IIGLU1)**2)
37934       IF(XMIST.GT.0.D0)THEN
37935       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
37936      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37937      *PHKT(1,5+IIGLU1)**2)
37938       ELSE
37939 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37940         PHKT(5,5+IIGLU1)=0.D0
37941       ENDIF
37942       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37943       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37944       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37945       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37946       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37947       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37948       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37949       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37950       IDHKT(6+IIGLU1)   =88888
37951 C     IDHKT(6)   =1000*NNNC1+MMMC1
37952       ISTHKT(6+IIGLU1)  =93
37953 C     ISTHKT(6)  =KKKC1
37954       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37955       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37956       JDAHKT(1,6+IIGLU1)=0
37957       JDAHKT(2,6+IIGLU1)=0
37958       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37959       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37960       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37961       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37962       PHKT(5,6+IIGLU1)
37963      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37964      *            -PHKT(3,6+IIGLU1)**2)
37965       CHAMAL=CHAM1
37966       IF(IPIP.EQ.1)THEN
37967         IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
37968       ELSEIF(IPIP.EQ.2)THEN
37969         IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
37970       ENDIF
37971       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37972         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37973 C                    we drop chain 6 and give the energy to chain 3
37974           IDHKT(6+IIGLU1)=33888
37975           XGIVE=1.D0
37976 C         WRITE(6,*)' drop chain 6 xgive=1'
37977           GO TO 7788
37978         ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
37979 C                    we drop chain 6 and give the energy to chain 3
37980 C                    and change KK11 to IDHKT(4)
37981           IDHKT(6+IIGLU1)=33888
37982           XGIVE=1.D0
37983 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
37984           KK11=IDHKT(4+IIGLU1)
37985           GO TO 7788
37986         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
37987 C                    we drop chain 6 and give the energy to chain 3
37988 C                    and change KK21 to IDHKT(4)
37989 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
37990           IDHKT(6+IIGLU1)=33888
37991           XGIVE=1.D0
37992 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
37993           KK21=IDHKT(4+IIGLU1)
37994           GO TO 7788
37995         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
37996 C                    we drop chain 6 and give the energy to chain 3
37997 C                    and change KK22 to IDHKT(4)
37998 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
37999           IDHKT(6+IIGLU1)=33888
38000           XGIVE=1.D0
38001 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
38002           KK22=IDHKT(4+IIGLU1)
38003           GO TO 7788
38004         ENDIF
38005 C       IREJ=1
38006         IPCO=0
38007 C       RETURN
38008 C       WRITE(6,*)' MGSQBS1 jump back from chain 6'
38009         GO TO 3466
38010       ENDIF
38011  7788 CONTINUE
38012       IF(IPIP.GE.3)THEN
38013       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38014      * JMOHKT(1,4+IIGLU1),
38015      * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38016      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38017       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38018      * JMOHKT(1,5+IIGLU1),
38019      * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38020      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38021       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38022      * JMOHKT(1,6+IIGLU1),
38023      * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38024      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38025       ENDIF
38026       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
38027       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
38028       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
38029       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
38030       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
38031       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
38032       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
38033       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
38034 C     IDHKT(1)   =IP11
38035       IDHKT(1)   =KK11
38036       ISTHKT(1)  =921
38037       JMOHKT(1,1)=NC1P
38038       JMOHKT(2,1)=0
38039       JDAHKT(1,1)=3+IIGLU1
38040       JDAHKT(2,1)=0
38041       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38042 C    * +0.5D0*PHKK(1,NC2P)
38043      *+XGIVE*PHKT(1,4+IIGLU1)
38044       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38045 C    * +0.5D0*PHKK(2,NC2P)
38046      *+XGIVE*PHKT(2,4+IIGLU1)
38047       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38048 C    * +0.5D0*PHKK(3,NC2P)
38049      *+XGIVE*PHKT(3,4+IIGLU1)
38050       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38051 C    * +0.5D0*PHKK(4,NC2P)
38052      *+XGIVE*PHKT(4,4+IIGLU1)
38053 C     PHKT(5,1)  =PHKK(5,NC1P)
38054       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38055      *PHKT(1,1)**2)
38056       IF(XMIST.GE.0.D0)THEN
38057       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38058      *PHKT(1,1)**2)
38059       ELSE
38060 C      WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
38061        PHKT(5,1)=0.D0
38062       ENDIF
38063       VHKT(1,1)  =VHKK(1,NC1P)
38064       VHKT(2,1)  =VHKK(2,NC1P)
38065       VHKT(3,1)  =VHKK(3,NC1P)
38066       VHKT(4,1)  =VHKK(4,NC1P)
38067       WHKT(1,1)  =WHKK(1,NC1P)
38068       WHKT(2,1)  =WHKK(2,NC1P)
38069       WHKT(3,1)  =WHKK(3,NC1P)
38070       WHKT(4,1)  =WHKK(4,NC1P)
38071 C     Add here IIGLU1 gluons to this chaina
38072       PG1=0.D0
38073       PG2=0.D0
38074       PG3=0.D0
38075       PG4=0.D0
38076       IF(IIGLU1.GE.1)THEN
38077       JJG=NC1P
38078       DO 61 IIG=2,2+IIGLU1-1
38079         KKG=JJG+IIG-1
38080         IDHKT(IIG)   =IDHKK(KKG)
38081         ISTHKT(IIG)  =921
38082         JMOHKT(1,IIG)=KKG
38083         JMOHKT(2,IIG)=0
38084         JDAHKT(1,IIG)=3+IIGLU1
38085         JDAHKT(2,IIG)=0
38086         PHKT(1,IIG)=PHKK(1,KKG)
38087         PG1=PG1+ PHKT(1,IIG)
38088         PHKT(2,IIG)=PHKK(2,KKG)
38089         PG2=PG2+ PHKT(2,IIG)
38090         PHKT(3,IIG)=PHKK(3,KKG)
38091         PG3=PG3+ PHKT(3,IIG)
38092         PHKT(4,IIG)=PHKK(4,KKG)
38093         PG4=PG4+ PHKT(4,IIG)
38094         PHKT(5,IIG)=PHKK(5,KKG)
38095         VHKT(1,IIG)  =VHKK(1,KKG)
38096         VHKT(2,IIG)  =VHKK(2,KKG)
38097         VHKT(3,IIG)  =VHKK(3,KKG)
38098         VHKT(4,IIG)  =VHKK(4,KKG)
38099         WHKT(1,IIG)  =WHKK(1,KKG)
38100         WHKT(2,IIG)  =WHKK(2,KKG)
38101         WHKT(3,IIG)  =WHKK(3,KKG)
38102         WHKT(4,IIG)  =WHKK(4,KKG)
38103    61 CONTINUE
38104       ENDIF
38105 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
38106       IF(IPIP.EQ.1)THEN
38107         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22+3
38108         IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
38109         IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
38110         IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
38111       ELSEIF(IPIP.EQ.2)THEN
38112         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22-3
38113         IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
38114         IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
38115         IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
38116       ENDIF
38117       ISTHKT(2+IIGLU1)  =922
38118       JMOHKT(1,2+IIGLU1)=NC2T
38119       JMOHKT(2,2+IIGLU1)=0
38120       JDAHKT(1,2+IIGLU1)=3+IIGLU1
38121       JDAHKT(2,2+IIGLU1)=0
38122       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
38123      *+XGIVE*PHKT(1,5+IIGLU1)
38124       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
38125      *+XGIVE*PHKT(2,5+IIGLU1)
38126       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
38127      *+XGIVE*PHKT(3,5+IIGLU1)
38128       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
38129      *+XGIVE*PHKT(4,5+IIGLU1)
38130 C     PHKT(5,2)  =PHKK(5,NC2T)
38131       XMIST=(PHKT(4,2+IIGLU1)**2-
38132      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38133      *PHKT(1,2+IIGLU1)**2)
38134       IF(XMIST.GT.0.D0)THEN
38135       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
38136      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38137      *PHKT(1,2+IIGLU1)**2)
38138       ELSE
38139 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38140       PHKT(5,2+IIGLU1)=0.D0
38141       ENDIF
38142       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
38143       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
38144       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
38145       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
38146       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
38147       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
38148       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
38149       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
38150       IDHKT(3+IIGLU1)   =88888
38151 C     IDHKT(3)   =1000*NNNC1+MMMC1+10
38152       ISTHKT(3+IIGLU1)  =93
38153 C     ISTHKT(3)  =KKKC1
38154       JMOHKT(1,3+IIGLU1)=1
38155       JMOHKT(2,3+IIGLU1)=2+IIGLU1
38156       JDAHKT(1,3+IIGLU1)=0
38157       JDAHKT(2,3+IIGLU1)=0
38158       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38159       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38160       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38161       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38162       PHKT(5,3+IIGLU1)
38163      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38164      *            -PHKT(3,3+IIGLU1)**2)
38165       IF(IPIP.GE.3)THEN
38166       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38167      * JDAHKT(1,1),
38168      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38169       DO 71 IIG=2,2+IIGLU1-1
38170       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38171      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38172      * JDAHKT(1,IIG),
38173      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38174    71 CONTINUE
38175       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
38176      &             IDHKT(2),JMOHKT(1,2+IIGLU1),
38177      * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38178      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38179       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38180      * JMOHKT(1,3+IIGLU1),
38181      * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38182      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38183       ENDIF
38184       CHAMAL=CHAB1
38185 **NEW
38186 C     IF(IPIP.EQ.1)THEN
38187 C       IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
38188 C     ELSEIF(IPIP.EQ.2)THEN
38189 C       IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
38190 C     ENDIF
38191       IF(IPIP.EQ.1)THEN
38192         IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
38193       ELSEIF(IPIP.EQ.2)THEN
38194         IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
38195       ENDIF
38196 **
38197       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38198 C       IREJ=1
38199         IPCO=0
38200 C       RETURN
38201 C       WRITE(6,*)' MGSQBS1 jump back from chain 3'
38202         GO TO 3466
38203       ENDIF
38204       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
38205       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
38206       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
38207       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
38208       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
38209       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
38210       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
38211       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
38212       IF(IPIP.EQ.1)THEN
38213         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ1+3
38214         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38215         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38216         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38217       ELSEIF(IPIP.EQ.2)THEN
38218         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
38219         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38220         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38221         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38222 C       WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
38223       ENDIF
38224       ISTHKT(7+IIGLU1)  =921
38225       JMOHKT(1,7+IIGLU1)=NC2P
38226       JMOHKT(2,7+IIGLU1)=0
38227       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38228       JDAHKT(2,7+IIGLU1)=0
38229 C     PHKT(1,7)  =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
38230 C     PHKT(2,7)  =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
38231 C     PHKT(3,7)  =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
38232 C     PHKT(4,7+IIGLU1)  =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
38233 **NEW
38234       IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
38235      &    WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
38236 **
38237       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38238       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38239       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38240       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38241 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38242 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38243       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38244 C       IREJ=1
38245 C       WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
38246         IPCO=0
38247 C       RETURN
38248         GO TO 3466
38249       ENDIF
38250 C     PHKT(5,7)  =PHKK(5,NC2P)
38251       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
38252      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38253      *PHKT(1,7+IIGLU1)**2)
38254       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
38255       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
38256       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
38257       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
38258       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
38259       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
38260       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
38261       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
38262 C     Insert here the IIGLU2 gluons
38263       PG1=0.D0
38264       PG2=0.D0
38265       PG3=0.D0
38266       PG4=0.D0
38267       IF(IIGLU2.GE.1)THEN
38268       JJG=NC2P
38269       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38270         KKG=JJG+IIG-7-IIGLU1
38271         IDHKT(IIG)   =IDHKK(KKG)
38272         ISTHKT(IIG)  =921
38273         JMOHKT(1,IIG)=KKG
38274         JMOHKT(2,IIG)=0
38275         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38276         JDAHKT(2,IIG)=0
38277         PHKT(1,IIG)=PHKK(1,KKG)
38278         PG1=PG1+ PHKT(1,IIG)
38279         PHKT(2,IIG)=PHKK(2,KKG)
38280         PG2=PG2+ PHKT(2,IIG)
38281         PHKT(3,IIG)=PHKK(3,KKG)
38282         PG3=PG3+ PHKT(3,IIG)
38283         PHKT(4,IIG)=PHKK(4,KKG)
38284         PG4=PG4+ PHKT(4,IIG)
38285         PHKT(5,IIG)=PHKK(5,KKG)
38286         VHKT(1,IIG)  =VHKK(1,KKG)
38287         VHKT(2,IIG)  =VHKK(2,KKG)
38288         VHKT(3,IIG)  =VHKK(3,KKG)
38289         VHKT(4,IIG)  =VHKK(4,KKG)
38290         WHKT(1,IIG)  =WHKK(1,KKG)
38291         WHKT(2,IIG)  =WHKK(2,KKG)
38292         WHKT(3,IIG)  =WHKK(3,KKG)
38293         WHKT(4,IIG)  =WHKK(4,KKG)
38294    81 CONTINUE
38295       ENDIF
38296       IDHKT(8+IIGLU1+IIGLU2)   =IP2
38297       ISTHKT(8+IIGLU1+IIGLU2)  =922
38298       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38299       JMOHKT(2,8+IIGLU1+IIGLU2)=0
38300       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38301       JDAHKT(2,8+IIGLU1+IIGLU2)=0
38302 **NEW
38303       IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
38304      &    WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
38305 **
38306       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38307       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38308       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38309       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38310 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
38311       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38312      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38313      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38314       IF(XMIST.GT.0.D0)THEN
38315       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38316      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38317      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38318       ELSE
38319 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38320       PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38321       ENDIF
38322       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
38323       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
38324       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
38325       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
38326       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
38327       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
38328       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
38329       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
38330       IDHKT(9+IIGLU1+IIGLU2)   =88888
38331 C     IDHKT(9)   =1000*NNNC2+MMMC2+10
38332       ISTHKT(9+IIGLU1+IIGLU2)  =93
38333 C     ISTHKT(9)  =KKKC2
38334       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38335       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38336       JDAHKT(1,9+IIGLU1+IIGLU2)=0
38337       JDAHKT(2,9+IIGLU1+IIGLU2)=0
38338       PHKT(1,9+IIGLU1+IIGLU2)  =PHKT(1,7+IIGLU1)
38339      * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
38340       PHKT(2,9+IIGLU1+IIGLU2)  =PHKT(2,7+IIGLU1)
38341      * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
38342       PHKT(3,9+IIGLU1+IIGLU2)  =PHKT(3,7+IIGLU1)
38343      * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
38344       PHKT(4,9+IIGLU1+IIGLU2)  =PHKT(4,7+IIGLU1)
38345      * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
38346       PHKT(5,9+IIGLU1+IIGLU2)
38347      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38348      * PHKT(2,9+IIGLU1+IIGLU2)**2
38349      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38350       IF(IPIP.GE.3)THEN
38351       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38352      * JMOHKT(1,7+IIGLU1),
38353      * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38354      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38355       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38356       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38357      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38358      * JDAHKT(1,IIG),
38359      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38360    91 CONTINUE
38361       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38362      * IDHKT(8+IIGLU1+IIGLU2),
38363      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38364      * JDAHKT(1,8+IIGLU1+IIGLU2),
38365      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38366       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38367      * IDHKT(9+IIGLU1+IIGLU2),
38368      * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
38369      * JDAHKT(1,9+IIGLU1+IIGLU2),
38370      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38371       ENDIF
38372       CHAMAL=CHAB1
38373       IF(IPIP.EQ.1)THEN
38374         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38375       ELSEIF(IPIP.EQ.2)THEN
38376         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38377       ENDIF
38378       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38379 C       IREJ=1
38380         IPCO=0
38381 C       RETURN
38382 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
38383 C    &  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38384         GO TO 3466
38385       ENDIF
38386       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
38387       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
38388       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
38389       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
38390       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
38391       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
38392       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
38393       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
38394 C
38395       IGCOUN=9+IIGLU1+IIGLU2
38396       IPCO=0
38397        RETURN
38398        END
38399
38400 *$ CREATE HKKHKT.FOR
38401 *COPY HKKHKT
38402 C
38403 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38404 C
38405       SUBROUTINE HKKHKT(I,J)
38406       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38407       SAVE
38408
38409 * event history
38410
38411       PARAMETER (NMXHKK=200000)
38412
38413       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38414      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38415      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38416
38417 * extended event history
38418       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38419      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38420      &                IHIST(2,NMXHKK)
38421
38422       PARAMETER (NTMHKK= 300)
38423       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38424      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38425      +(4,NTMHKK)
38426 C
38427       ISTHKK(I)  =ISTHKT(J)
38428       IDHKK(I)   =IDHKT(J)
38429 C     IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
38430       IF(IDHKK(I).EQ.88888)THEN
38431 C       JMOHKK(1,I)=I-2
38432 C       JMOHKK(2,I)=I-1
38433         JMOHKK(1,I)=I-(J-JMOHKT(1,J))
38434         JMOHKK(2,I)=I-(J-JMOHKT(2,J))
38435       ELSE
38436         JMOHKK(1,I)=JMOHKT(1,J)
38437         JMOHKK(2,I)=JMOHKT(2,J)
38438       ENDIF
38439       JDAHKK(1,I)=JDAHKT(1,J)
38440       JDAHKK(2,I)=JDAHKT(2,J)
38441 C       IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
38442 C       JDAHKK(1,I)=I+2
38443 C     ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
38444 C       JDAHKK(1,I)=I+1
38445 C     ENDIF
38446       IF(JDAHKT(1,J).GT.0)THEN
38447         JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
38448       ENDIF
38449       PHKK(1,I)  =PHKT(1,J)
38450       PHKK(2,I)  =PHKT(2,J)
38451       PHKK(3,I)  =PHKT(3,J)
38452       PHKK(4,I)  =PHKT(4,J)
38453       PHKK(5,I)  =PHKT(5,J)
38454       VHKK(1,I)  =VHKT(1,J)
38455       VHKK(2,I)  =VHKT(2,J)
38456       VHKK(3,I)  =VHKT(3,J)
38457       VHKK(4,I)  =VHKT(4,J)
38458       WHKK(1,I)  =WHKT(1,J)
38459       WHKK(2,I)  =WHKT(2,J)
38460       WHKK(3,I)  =WHKT(3,J)
38461       WHKK(4,I)  =WHKT(4,J)
38462       RETURN
38463       END
38464
38465 *$ CREATE DT_DBREAK.FOR
38466 *COPY DT_DBREAK
38467 *
38468 *===dbreak=============================================================*
38469 *
38470       SUBROUTINE DT_DBREAK(MODE)
38471
38472 ************************************************************************
38473 * This is the steering subroutine for the different diquark breaking   *
38474 * mechanisms.                                                          *
38475 *                                                                      *
38476 * MODE = 1  breaking of projectile diquark in qq-q chain using         *
38477 *           a sea quark (q-qq chain) of the same projectile            *
38478 *      = 2  breaking of target     diquark in q-qq chain using         *
38479 *           a sea quark (qq-q chain) of the same target                *
38480 *      = 3  breaking of projectile diquark in qq-q chain using         *
38481 *           a sea quark (q-aq chain) of the same projectile            *
38482 *      = 4  breaking of target     diquark in q-qq chain using         *
38483 *           a sea quark (aq-q chain) of the same target                *
38484 *      = 5  breaking of projectile anti-diquark in aqaq-aq chain using *
38485 *           a sea anti-quark (aq-aqaq chain) of the same projectile    *
38486 *      = 6  breaking of target     anti-diquark in aq-aqaq chain using *
38487 *           a sea anti-quark (aqaq-aq chain) of the same target        *
38488 *      = 7  breaking of projectile anti-diquark in aqaq-aq chain using *
38489 *           a sea anti-quark (aq-q chain) of the same projectile       *
38490 *      = 8  breaking of target     anti-diquark in aq-aqaq chain using *
38491 *           a sea anti-quark (q-aq chain) of the same target           *
38492 *                                                                      *
38493 * Original version by J. Ranft.                                        *
38494 * This version dated 17.5.00  is written by S. Roesler.                *
38495 ************************************************************************
38496
38497       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38498       SAVE
38499
38500       PARAMETER ( LINP = 10 ,
38501      &            LOUT = 6 ,
38502      &            LDAT = 9 )
38503
38504 * event history
38505
38506       PARAMETER (NMXHKK=200000)
38507
38508       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38509      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38510      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38511
38512 * extended event history
38513       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38514      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38515      &                IHIST(2,NMXHKK)
38516
38517 * flags for input different options
38518       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
38519       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
38520      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
38521
38522 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
38523       PARAMETER (MAXCHN=10000)
38524       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
38525
38526 * diquark-breaking mechanism
38527       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38528
38529 * flags for particle decays
38530       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
38531      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
38532      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
38533
38534 *
38535 * chain identifiers
38536 * ( 1 = q-aq,   2 = aq-q,   3 = q-qq,   4 = qq-q,
38537 *   5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
38538       DIMENSION IDCHN1(8),IDCHN2(8)
38539       DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
38540       DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
38541 *
38542 * parton identifiers
38543 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
38544 *   +-51/52 = unitarity-sea, +-61/62 = gluons )
38545       DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
38546       DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
38547      &             31, 31, 31, 31, 31, 31, 31, 31,
38548      &             41, 41, 41, 41, 51, 51, 51, 51/
38549       DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
38550      &             32, 32, 32, 32, 32, 32, 32, 32,
38551      &             42, 42, 42, 42, 52, 52, 52, 52/
38552       DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
38553      &             51, 31, 41, 41, 31, 31, 31, 31,
38554      &              0, 41, 51, 51, 51, 51, 51, 51/
38555       DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
38556      &             32, 52, 42, 42, 32, 32, 32, 32,
38557      &             42,  0, 52, 52, 52, 52, 52, 52/
38558
38559       IF (NCHAIN.LE.0) RETURN
38560       DO 1 I=1,NCHAIN
38561          IDX1 = IDXCHN(1,I)
38562          IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
38563          IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
38564          IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
38565      &       .AND.
38566      &        ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
38567      &                                    (IS1P.EQ.ISP1P(MODE,3)))
38568      &       .AND.
38569      &        ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
38570      &                                    (IS1T.EQ.ISP1T(MODE,3)))
38571      &      ) THEN
38572             DO 2 J=1,NCHAIN
38573                IDX2 = IDXCHN(1,J)
38574                IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
38575                IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
38576                IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
38577      &             .AND.
38578      &              ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
38579      &                                      .OR.(IS2P.EQ.ISP2P(MODE,3)))
38580      &             .AND.
38581      &              ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
38582      &                                      .OR.(IS2T.EQ.ISP2T(MODE,3)))
38583      &            ) THEN
38584 *   find mother nucleons of the diquark to be splitted and of the
38585 *   sea-quark and reject this combination if it is not the same
38586                   IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
38587      &                (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
38588                      IANCES = 1
38589                   ELSE
38590                      IANCES = 2
38591                   ENDIF
38592                   IDXMO1 = JMOHKK(IANCES,IDX1)
38593     4             CONTINUE
38594                   IF ((JMOHKK(1,IDXMO1).NE.0).AND.
38595      &                (JMOHKK(2,IDXMO1).NE.0)) THEN
38596                      IANC = IANCES
38597                   ELSE
38598                      IANC = 1
38599                   ENDIF
38600                   IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
38601                      IDXMO1 = JMOHKK(IANC,IDXMO1)
38602                      GOTO 4
38603                   ENDIF
38604                   IDXMO2 = JMOHKK(IANCES,IDX2)
38605     5             CONTINUE
38606                   IF ((JMOHKK(1,IDXMO2).NE.0).AND.
38607      &                (JMOHKK(2,IDXMO2).NE.0)) THEN
38608                      IANC = IANCES
38609                   ELSE
38610                      IANC = 1
38611                   ENDIF
38612                   IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
38613                      IDXMO2 = JMOHKK(IANC,IDXMO2)
38614                      GOTO 5
38615                   ENDIF
38616                   IF (IDXMO1.NE.IDXMO2) GOTO 2
38617 *   quark content of projectile parton
38618                   IP1   = IDHKK(JMOHKK(1,IDX1))
38619                   IP11  = IP1/1000
38620                   IP12  = (IP1-1000*IP11)/100
38621                   IP2   = IDHKK(JMOHKK(2,IDX1))
38622                   IP21  = IP2/1000
38623                   IP22  = (IP2-1000*IP21)/100
38624 *   quark content of target parton
38625                   IT1  = IDHKK(JMOHKK(1,IDX2))
38626                   IT11 = IT1/1000
38627                   IT12 = (IT1-1000*IT11)/100
38628                   IT2  = IDHKK(JMOHKK(2,IDX2))
38629                   IT21 = IT2/1000
38630                   IT22 = (IT2-1000*IT21)/100
38631 *   split diquark and form new chains
38632                   IF (MODE.EQ.1) THEN
38633                      IF (IT1.EQ.4) GOTO 2
38634                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38635      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38636      &                         IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
38637                   ELSEIF (MODE.EQ.2) THEN
38638                      IF (IT2.EQ.4) GOTO 2
38639                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38640      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38641      &                         IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
38642                   ELSEIF (MODE.EQ.3) THEN
38643                      IF (IT1.EQ.4) GOTO 2
38644                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38645      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38646      &                         IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
38647                   ELSEIF (MODE.EQ.4) THEN
38648                      IF (IT2.EQ.4) GOTO 2
38649                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38650      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38651      &                         IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
38652                   ELSEIF (MODE.EQ.5) THEN
38653                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38654      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38655      &                         IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
38656                   ELSEIF (MODE.EQ.6) THEN
38657                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38658      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38659      &                         IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
38660                   ELSEIF (MODE.EQ.7) THEN
38661                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38662      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38663      &                         IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
38664                   ELSEIF (MODE.EQ.8) THEN
38665                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38666      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38667      &                         IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
38668                   ENDIF
38669                   IF (IREJ.GE.1) THEN
38670                      if ((ipq.lt.0).or.(ipq.ge.4))
38671      &                  write(LOUT,*) 'ipq !!!',ipq,mode
38672                      DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38673 *   accept or reject new chains corresponding to PDBSEA
38674                   ELSE
38675                      IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
38676                         ACC   = DBRKA(1,MODE)+DBRKA(2,MODE)
38677                         REJ   = DBRKR(1,MODE)+DBRKR(2,MODE)
38678                      ELSEIF (IPQ.EQ.3) THEN
38679                         ACC   = DBRKA(3,MODE)
38680                         REJ   = DBRKR(3,MODE)
38681                      ELSE
38682                         WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
38683                         STOP
38684                      ENDIF
38685                      IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
38686                         DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
38687                         IACC = 1
38688                      ELSE
38689                         DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38690                         IACC = 0
38691                      ENDIF
38692 *   new chains have been accepted and are now copied into HKKEVT
38693                      IF (IACC.EQ.1) THEN
38694                         IF (LEMCCK) THEN
38695                            CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
38696      &                                    PHKK(3,IDX1),PHKK(4,IDX1),
38697      &                                    1,IDUM1,IDUM2)
38698                            CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
38699      &                                    PHKK(3,IDX2),PHKK(4,IDX2),
38700      &                                    2,IDUM1,IDUM2)
38701                         ENDIF
38702                         IDHKK(IDX1) = 99888
38703                         IDHKK(IDX2) = 99888
38704                         IDXCHN(2,I) = -1
38705                         IDXCHN(2,J) = -1
38706                         DO 3 K=1,IGCOUN
38707                            NHKK = NHKK+1
38708                            CALL HKKHKT(NHKK,K)
38709                            IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
38710                               PX = -PHKK(1,NHKK)
38711                               PY = -PHKK(2,NHKK)
38712                               PZ = -PHKK(3,NHKK)
38713                               PE = -PHKK(4,NHKK)
38714                               CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
38715                            ENDIF
38716     3                   CONTINUE
38717                         IF (LEMCCK) THEN
38718                            CHKLEV = 0.1D0
38719                            CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
38720      &                                                             IREJ)
38721                            IF (IREJ.NE.0) CALL DT_EVTOUT(4)
38722                         ENDIF
38723                         GOTO 1
38724                      ENDIF
38725                   ENDIF
38726                ENDIF
38727     2       CONTINUE
38728          ENDIF
38729     1 CONTINUE
38730       RETURN
38731       END
38732
38733 *$ CREATE DT_CQPAIR.FOR
38734 *COPY DT_CQPAIR
38735 *
38736 *===cqpair=============================================================*
38737 *
38738       SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
38739
38740 ************************************************************************
38741 * This subroutine Creates a Quark-antiquark PAIR from the sea.         *
38742 *                                                                      *
38743 *   XQMAX   maxium energy fraction of quark (input)                    *
38744 *   XAQMAX  maxium energy fraction of antiquark (input)                *
38745 *   XQ      energy fraction of quark (output)                          *
38746 *   XAQ     energy fraction of antiquark (output)                      *
38747 *   IFLV    quark flavour (- antiquark flavor) (output)                *
38748 *                                                                      *
38749 * This version dated 14.5.00  is written by S. Roesler.                *
38750 ************************************************************************
38751
38752       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38753       SAVE
38754
38755       PARAMETER ( LINP = 10 ,
38756      &            LOUT = 6 ,
38757      &            LDAT = 9 )
38758
38759 * Lorentz-parameters of the current interaction
38760       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38761      &                UMO,PPCM,EPROJ,PPROJ
38762
38763 *
38764       IREJ = 0
38765       XQ   = 0.0D0
38766       XAQ  = 0.0D0
38767 *
38768 * sample quark flavour
38769 *
38770 *  set seasq here (the one from DTCHAI should be used in the future)
38771       SEASQ = 0.5D0
38772       IFLV  = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
38773 *
38774 * sample energy fractions of sea pair
38775 * we first sample the energy fraction of a gluon and then split the gluon
38776 *
38777 *  maximum energy fraction of the gluon forced via input
38778       XGMAXI = XQMAX+XAQMAX
38779 *  minimum energy fraction of the gluon
38780       XTHR1 = 4.0D0 /UMO**2
38781       XTHR2 = 0.54D0/UMO**1.5D0
38782       XGMIN = MAX(XTHR1,XTHR2)
38783 *  maximum energy fraction of the gluon
38784       XGMAX = 0.3D0
38785       XGMAX = MIN(XGMAXI,XGMAX)
38786       IF (XGMIN.GE.XGMAX) THEN
38787          IREJ = 1
38788          RETURN
38789       ENDIF
38790 *
38791 *  sample energy fraction of the gluon
38792       NLOOP = 0
38793     1 CONTINUE
38794       NLOOP = NLOOP+1
38795       IF (NLOOP.GE.50) THEN
38796          IREJ = 1
38797          RETURN
38798       ENDIF
38799       XGLUON = DT_SAMSQX(XGMIN,XGMAX)
38800       EGLUON = XGLUON*UMO/2.0D0
38801 *
38802 *  split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
38803       ZMIN = MIN(0.1D0,0.5D0/EGLUON)
38804       ZMAX = 1.0D0-ZMIN
38805       RZ   = DT_RNDM(ZMAX)
38806       XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
38807       RQ   = DT_RNDM(ZMAX)
38808       IF (RQ.LT.0.5D0) THEN
38809          XQ  = XGLUON*XHLP
38810          XAQ = XGLUON-XQ
38811       ELSE
38812          XAQ = XGLUON*XHLP
38813          XQ  = XGLUON-XAQ
38814       ENDIF
38815       IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
38816
38817       RETURN
38818       END