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. (IT.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
3596             IF ((ABS(ISTHKK(I)).EQ.1)  .OR.
3597      &           (ABS(ISTHKK(I)).EQ.2) .OR.
3598      &           (ISTHKK(I).EQ.1000)   .OR.
3599      &           (ISTHKK(I).EQ.1001)) THEN
3600
3601                CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3602      &                     COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3603                PECMS = PHKK(4,I)
3604                CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3605      &                     PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3606             ENDIF
3607    20    CONTINUE
3608       ELSE
3609          MODE = -1
3610       ENDIF
3611
3612       RETURN
3613       END
3614
3615 *$ CREATE DT_REJUCO.FOR
3616 *COPY DT_REJUCO
3617 *
3618 *===rejuco=============================================================*
3619 *
3620       SUBROUTINE DT_REJUCO(MODE,IREJ)
3621
3622 ************************************************************************
3623 * REJection of Unphysical COnfigurations                               *
3624 *     MODE = 1  rejection of particles with unphysically large energy  *
3625 *                                                                      *
3626 * This version dated 27.12.2006 is written by S. Roesler.              *
3627 ************************************************************************
3628
3629       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3630       SAVE
3631
3632       PARAMETER ( LINP = 10 ,
3633      &            LOUT = 6 ,
3634      &            LDAT = 9 )
3635
3636       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3637       PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3638
3639 * maximum x_cms of final state particle
3640       PARAMETER (XCMSMX = 1.4D0)
3641
3642 * event history
3643
3644       PARAMETER (NMXHKK=200000)
3645
3646       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3647      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3648      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3649
3650 * extended event history
3651       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3652      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3653      &                IHIST(2,NMXHKK)
3654
3655 * Lorentz-parameters of the current interaction
3656       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3657      &                UMO,PPCM,EPROJ,PPROJ
3658
3659       IREJ = 0
3660
3661       IF (MODE.EQ.1) THEN
3662          IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3663          ECMHLF = UMO/2.0D0
3664          DO 10 I=NPOINT(4),NHKK
3665             IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3666                XCMS = ABS(PHKK(4,I))/ECMHLF
3667                IF (XCMS.GT.XCMSMX) GOTO 9999
3668             ENDIF
3669    10    CONTINUE
3670       ENDIF
3671
3672       RETURN
3673  9999 CONTINUE
3674       IREJ = 1
3675       RETURN
3676       END
3677 *$ CREATE DT_EVENTB.FOR
3678 *COPY DT_EVENTB
3679 *
3680 *===eventb=============================================================*
3681 *
3682       SUBROUTINE DT_EVENTB(NCSY,IREJ)
3683
3684 ************************************************************************
3685 * Treatment of nucleon-nucleon interactions with full two-component    *
3686 * Dual Parton Model.                                                   *
3687 *          NCSY     number of nucleon-nucleon interactions             *
3688 *          IREJ     rejection flag                                     *
3689 * This version dated 14.01.2000 is written by S. Roesler               *
3690 ************************************************************************
3691
3692       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3693       SAVE
3694
3695       PARAMETER ( LINP = 10 ,
3696      &            LOUT = 6 ,
3697      &            LDAT = 9 )
3698
3699       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3700
3701 * event history
3702
3703       PARAMETER (NMXHKK=200000)
3704
3705       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3706      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3707      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3708
3709 * extended event history
3710       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3711      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3712      &                IHIST(2,NMXHKK)
3713 *! uncomment this line for internal phojet-fragmentation
3714 C #include "dtu_dtevtp.inc"
3715
3716 * particle properties (BAMJET index convention)
3717       CHARACTER*8  ANAME
3718       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3719      &                IICH(210),IIBAR(210),K1(210),K2(210)
3720
3721 * flags for input different options
3722       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3723       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3724      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3725
3726 * rejection counter
3727       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3728      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3729      &                IREXCI(3),IRDIFF(2),IRINC
3730
3731 * properties of interacting particles
3732       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3733
3734 * properties of photon/lepton projectiles
3735       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3736
3737 * various options for treatment of partons (DTUNUC 1.x)
3738 * (chain recombination, Cronin,..)
3739       LOGICAL LCO2CR,LINTPT
3740       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3741      &                LCO2CR,LINTPT
3742
3743 * statistics
3744       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3745      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3746      &                ICEVTG(8,0:30)
3747
3748 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3749       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3750
3751 * Glauber formalism: collision properties
3752       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3753      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
3754      &                NCP,NCT
3755 * flags for diffractive interactions (DTUNUC 1.x)
3756       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3757
3758 * statistics: double-Pomeron exchange
3759       COMMON /DTFLG2/ INTFLG,IPOPO
3760
3761 * flags for particle decays
3762       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3763      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3764      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3765
3766 * nucleon-nucleon event-generator
3767       CHARACTER*8 CMODEL
3768       LOGICAL LPHOIN
3769       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3770
3771 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
3772       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3773       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3774       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3775      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3776
3777 C  model switches and parameters
3778       CHARACTER*8 MDLNA
3779       INTEGER ISWMDL,IPAMDL
3780       DOUBLE PRECISION PARMDL
3781       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3782
3783 C  initial state parton radiation (internal part)
3784       INTEGER MXISR3,MXISR4
3785       PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3786       INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3787       DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3788       COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3789      &                ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3790      &                IFL1(2,MXISR3),IFL2(2,MXISR3),
3791      &                IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3792
3793 C  event debugging information
3794       INTEGER NMAXD
3795       PARAMETER (NMAXD=100)
3796       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3797      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3798       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3799      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3800
3801 C  general process information
3802       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3803       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3804
3805       DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3806      &          PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3807      &          PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3808      &          KPRON(15),ISINGL(2000)
3809
3810 * initial values for max. number of phojet scatterings and dtunuc chains
3811 * to be fragmented with one pyexec call
3812       DATA MXPHFR,MXDTFR /10,100/
3813
3814       IREJ      = 0
3815 * pointer to first parton of the first chain in dtevt common
3816       NPOINT(3) = NHKK+1
3817 * special flag for double-Pomeron statistics
3818       IPOPO = 1
3819 * counter for low-mass (DTUNUC) interactions
3820       NDTUSC = 0
3821 * counter for interactions treated by PHOJET
3822       NPHOSC = 0
3823
3824 * scan interactions for single nucleon-nucleon interactions
3825 * (this has to be checked here because Cronin modifies parton momenta)
3826       NC = NPOINT(2)
3827       IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3828       DO 8 I=1,NCSY
3829          ISINGL(I) = 0
3830          MOP = JMOHKK(1,NC)
3831          MOT = JMOHKK(1,NC+1)
3832          DIFF1 = ABS(PHKK(4,MOP)-PHKK(4,  NC)-PHKK(4,NC+2))
3833          DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3834          IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3835          NC = NC+4
3836     8 CONTINUE
3837
3838 * multiple scattering of chain ends
3839       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3840       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3841
3842 * switch to PHOJET-settings for JETSET parameter
3843       CALL DT_INITJS(1)
3844
3845 * loop over nucleon-nucleon interaction
3846       NC = NPOINT(2)
3847       DO 2 I=1,NCSY
3848 *
3849 *   pick up one nucleon-nucleon interaction from DTEVT1
3850 *     ppnn  / ptnn   - momenta of the interacting nucleons (cms)
3851 *     ptotnn         - total momentum of the interacting nucleons (cms)
3852 *     pp1,2 / pt1,2  - momenta of the four partons
3853 *     pp    / pt     - total momenta of the proj / targ partons
3854 *     ptot           - total momentum of the four partons
3855          MOP = JMOHKK(1,NC)
3856          MOT = JMOHKK(1,NC+1)
3857          DO 3 K=1,4
3858             PPNN(K)   = PHKK(K,MOP)
3859             PTNN(K)   = PHKK(K,MOT)
3860             PTOTNN(K) = PPNN(K)+PTNN(K)
3861             PP1(K)    = PHKK(K,NC)
3862             PT1(K)    = PHKK(K,NC+1)
3863             PP2(K)    = PHKK(K,NC+2)
3864             PT2(K)    = PHKK(K,NC+3)
3865             PP(K)     = PP1(K)+PP2(K)
3866             PT(K)     = PT1(K)+PT2(K)
3867             PTOT(K)   = PP(K)+PT(K)
3868     3    CONTINUE
3869 *
3870 *-----------------------------------------------------------------------
3871 *   this is a complete nucleon-nucleon interaction
3872 *
3873          IF (ISINGL(I).EQ.1) THEN
3874 *
3875 *     initialize PHOJET-variables for remnant/valence-partons
3876             IHFLD(1,1) = 0
3877             IHFLD(1,2) = 0
3878             IHFLD(2,1) = 0
3879             IHFLD(2,2) = 0
3880             IHFLS(1) = 1
3881             IHFLS(2) = 1
3882 *     save current settings of PHOJET process and min. bias flags
3883             DO 9 K=1,11
3884                KPRON(K) = IPRON(K,1)
3885     9       CONTINUE
3886             ISWSAV   = ISWMDL(2)
3887 *
3888 *     check if forced sampling of diffractive interaction requested
3889             IF (ISINGD.LT.-1) THEN
3890                DO 90 K=1,11
3891                   IPRON(K,1) = 0
3892    90          CONTINUE
3893                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3894                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3895                IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3896             ENDIF
3897 *
3898 *     for photons: a direct/anomalous interaction is not sampled
3899 *     in PHOJET but already in Glauber-formalism. Here we check if such
3900 *     an interaction is requested
3901             IF (IJPROJ.EQ.7) THEN
3902 *       first switch off direct interactions
3903                IPRON(8,1) = 0
3904 *       this is a direct interactions
3905                IF (IDIREC.EQ.1) THEN
3906                   DO 12 K=1,11
3907                      IPRON(K,1) = 0
3908    12             CONTINUE
3909                   IPRON(8,1) = 1
3910 *       this is an anomalous interactions
3911 *         (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3912                ELSEIF (IDIREC.EQ.2) THEN
3913                   ISWMDL(2) = 0
3914                ENDIF
3915             ELSE
3916                IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3917             ENDIF
3918 *
3919 *     make sure that total momenta of partons, pp and pt, are on mass
3920 *     shell (Cronin may have srewed this up..)
3921             CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3922             IF (IR1.NE.0) THEN
3923                IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3924      &              'EVENTB:  mass shell correction rejected'
3925                GOTO 9999
3926             ENDIF
3927 *
3928 *     initialize the incoming particles in PHOJET
3929             IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3930
3931                CALL PHO_SETPAR(1,22,0,VIRT)
3932
3933             ELSE
3934
3935                CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3936
3937             ENDIF
3938
3939             CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3940
3941 *
3942 *     initialize rejection loop counter for anomalous processes
3943             IRJANO = 0
3944   800       CONTINUE
3945             IRJANO = IRJANO+1
3946 *
3947 *     temporary fix for ifano problem
3948             IFANO(1) = 0
3949             IFANO(2) = 0
3950 *
3951 *     generate complete hadron/nucleon/photon-nucleon event with PHOJET
3952
3953             CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3954
3955 *
3956 *     for photons: special consistency check for anomalous interactions
3957             IF (IJPROJ.EQ.7) THEN
3958                IF (IRJANO.LT.30) THEN
3959                   IF (IFANO(1).NE.0) THEN
3960 *       here, an anomalous interaction was generated. Check if it
3961 *       was also requested. Otherwise reject this event.
3962                      IF (IDIREC.EQ.0) GOTO 800
3963                   ELSE
3964 *       here, an anomalous interaction was not generated. Check if it
3965 *       was requested in which case we need to reject this event.
3966                      IF (IDIREC.EQ.2) GOTO 800
3967                   ENDIF
3968                ELSE
3969                   WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3970      &                          IRJANO,IDIREC,NEVHKK
3971                ENDIF
3972             ENDIF
3973 *
3974 *     copy back original settings of PHOJET process and min. bias flags
3975             DO 10 K=1,11
3976                IPRON(K,1) = KPRON(K)
3977    10       CONTINUE
3978             ISWMDL(2) = ISWSAV
3979 *
3980 *     check if PHOJET has rejected this event
3981             IF (IREJ1.NE.0) THEN
3982 C              IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3983                WRITE(LOUT,'(1X,A,I4)')
3984      &            'EVENTB:  chain system rejected',IDIREC
3985
3986                CALL PHO_PREVNT(0)
3987
3988                GOTO 9999
3989             ENDIF
3990 *
3991 *     copy partons and strings from PHOJET common back into DTEVT for
3992 *     external fragmentation
3993             MO1 = NC
3994             MO2 = NC+3
3995 *!      uncomment this line for internal phojet-fragmentation
3996 C           CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3997             NPHOSC = NPHOSC+1
3998             CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3999             IF (IREJ1.NE.0) THEN
4000                IF (IOULEV(1).GT.0)
4001      &         WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
4002                GOTO 9999
4003             ENDIF
4004 *
4005 *     update statistics counter
4006             ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
4007 *
4008 *-----------------------------------------------------------------------
4009 *   this interaction involves "remnants"
4010 *
4011          ELSE
4012 *
4013 *     total mass of this system
4014             PPTOT  = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
4015             AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
4016             IF (AMTOT2.LT.ZERO) THEN
4017                AMTOT = ZERO
4018             ELSE
4019                AMTOT = SQRT(AMTOT2)
4020             ENDIF
4021 *
4022 *     systems with masses larger than elojet are treated with PHOJET
4023             IF (AMTOT.GT.ELOJET) THEN
4024 *
4025 *     initialize PHOJET-variables for remnant/valence-partons
4026 *       projectile parton flavors and valence flag
4027                IHFLD(1,1) = IDHKK(NC)
4028                IHFLD(1,2) = IDHKK(NC+2)
4029                IHFLS(1)   = 0
4030                IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
4031      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
4032 *       target parton flavors and valence flag
4033                IHFLD(2,1) = IDHKK(NC+1)
4034                IHFLD(2,2) = IDHKK(NC+3)
4035                IHFLS(2)   = 0
4036                IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
4037      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
4038 *       flag signalizing PHOJET how to treat the remnant:
4039 *         iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
4040 *         iremn > -1 valence remnant: PHOJET assumes flavors according
4041 *                    to mother particle
4042                IREMN1 = IHFLS(1)-1
4043                IREMN2 = IHFLS(2)-1
4044 *
4045 *     initialize the incoming particles in PHOJET
4046                IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
4047
4048                   CALL PHO_SETPAR(1,22,IREMN1,VIRT)
4049
4050                ELSE
4051
4052                   CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
4053
4054                ENDIF
4055
4056                CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
4057
4058 *
4059 *     calculate Lorentz parameter of the nucleon-nucleon cm-system
4060                PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
4061                AMNN   = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
4062                BGX    = PTOTNN(1)/AMNN
4063                BGY    = PTOTNN(2)/AMNN
4064                BGZ    = PTOTNN(3)/AMNN
4065                GAM    = PTOTNN(4)/AMNN
4066 *     transform interacting nucleons into nucleon-nucleon cm-system
4067                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4068      &                     PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
4069      &                     PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
4070                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4071      &                     PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
4072      &                     PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
4073 *     transform (total) momenta of the proj and targ partons into
4074 *     nucleon-nucleon cm-system
4075                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4076      &                     PP(1),PP(2),PP(3),PP(4),
4077      &                     PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
4078                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4079      &                     PT(1),PT(2),PT(3),PT(4),
4080      &                     PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
4081 *     energy fractions of the proj and targ partons
4082                XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
4083                XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
4084 ***
4085 * testprint
4086 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
4087 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
4088 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
4089 c              EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
4090 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
4091 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
4092 c    &                        (PPSUB(2)+PTSUB(2))**2 +
4093 c    &                        (PPSUB(3)+PTSUB(3))**2 )
4094 c              EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
4095 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
4096 ***
4097 *
4098 *     save current settings of PHOJET process and min. bias flags
4099                DO 7 K=1,11
4100                   KPRON(K) = IPRON(K,1)
4101     7          CONTINUE
4102 *     disallow direct photon int. (does not make sense here anyway)
4103                IPRON(8,1) = 0
4104 *     disallow double pomeron processes (due to technical problems
4105 *     in PHOJET, needs to be solved sometime)
4106                IPRON(4,1) = 0
4107 *     disallow diffraction for sea-diquarks
4108                IF ((IABS(IHFLD(1,1)).GT.1100).AND.
4109      &             (IABS(IHFLD(1,2)).GT.1100)) THEN
4110                   IPRON(3,1) = 0
4111                   IPRON(6,1) = 0
4112                ENDIF
4113                IF ((IABS(IHFLD(2,1)).GT.1100).AND.
4114      &             (IABS(IHFLD(2,2)).GT.1100)) THEN
4115                   IPRON(3,1) = 0
4116                   IPRON(5,1) = 0
4117                ENDIF
4118 *
4119 *     we need massless partons: transform them on mass shell
4120                XMP = ZERO
4121                XMT = ZERO
4122                DO 6 K=1,4
4123                   PPTMP(K) = PPSUB(K)
4124                   PTTMP(K) = PTSUB(K)
4125     6          CONTINUE
4126                CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
4127                PPSUTO  = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
4128                PTSUTO  = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
4129                PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
4130      &                  (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
4131 *     total energy of the subsysten after mass transformation
4132 *      (should be the same as before..)
4133                SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
4134      &                      (PPSUB(4)+PTSUB(4)+PSUTOT) )
4135 *
4136 *     after mass shell transformation the x_sub - relation has to be
4137 *     corrected. We therefore create "pseudo-momenta" of mother-nucleons.
4138 *
4139 *     The old version was to scale based on the original x_sub and the
4140 *     4-momenta of the subsystem. At very high energy this could lead to
4141 *     "pseudo-cm energies" of the parent system considerably exceeding
4142 *     the true cm energy. Now we keep the true cm energy and calculate
4143 *     new x_sub instead.
4144 C old version  PPTCMS(4) = PPSUB(4)/XPSUB
4145                PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
4146                XPSUB = PPSUB(4)/PPTCMS(4)
4147                IF (IJPROJ.EQ.7) THEN
4148                   AMP2  = PHKK(5,MOT)**2
4149                   PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
4150                ELSE
4151 *???????
4152                   PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
4153      &                        *(PPTCMS(4)+PHKK(5,MOP)))
4154 C                 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
4155 C    &                        *(PPTCMS(4)+PHKK(5,MOT)))
4156                ENDIF
4157 C old version  PTTCMS(4) = PTSUB(4)/XTSUB
4158                PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
4159                XTSUB = PTSUB(4)/PTTCMS(4)
4160                PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
4161      &                     *(PTTCMS(4)+PHKK(5,MOT)))
4162                DO 4 K=1,3
4163                   PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
4164                   PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
4165     4          CONTINUE
4166 ***
4167 * testprint
4168 *
4169 *     ppnn  / ptnn   - momenta of the int. nucleons (cms, negl. Fermi)
4170 *     ptotnn         - total momentum of the int. nucleons (cms, negl. Fermi)
4171 *     pptcms/ pttcms - momenta of the interacting nucleons (cms)
4172 *     pp1,2 / pt1,2  - momenta of the four partons
4173 *
4174 *     pp    / pt     - total momenta of the pr/ta partons (cms, negl. Fermi)
4175 *     ptot           - total momentum of the four partons (cms, negl. Fermi)
4176 *     ppsub / ptsub  - total momenta of the proj / targ partons (cms)
4177 *
4178 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
4179 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
4180 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
4181 c              ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
4182 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
4183 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
4184 c    &                        (PPSUB(2)+PTSUB(2))**2 +
4185 c    &                        (PPSUB(3)+PTSUB(3))**2 )
4186 c              ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
4187 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
4188 c              IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
4189 c                 WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
4190 c                 WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
4191 c                 WRITE(*,*) ' XPSUB,  XTSUB  : ',XPSUB,XTSUB
4192 c              ENDIF
4193 c              BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
4194 c              BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
4195 c              BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
4196 c              BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
4197 *     transform interacting nucleons into nucleon-nucleon cm-system
4198 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4199 c    &                    PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
4200 c    &                     PPNEW1,PPNEW2,PPNEW3,PPNEW4)
4201 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4202 c    &                    PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
4203 c    &                     PTNEW1,PTNEW2,PTNEW3,PTNEW4)
4204 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4205 c    &                     PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
4206 c    &                     PPSUB1,PPSUB2,PPSUB3,PPSUB4)
4207 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4208 c    &                     PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
4209 c    &                     PTSUB1,PTSUB2,PTSUB3,PTSUB4)
4210 c              PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
4211 c    &                        (PPNEW2+PTNEW2)**2 +
4212 c    &                        (PPNEW3+PTNEW3)**2 )
4213 c              ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
4214 c    &                        (PPNEW4+PTNEW4+PTSTCM) )
4215 c              PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
4216 c    &                        (PPSUB2+PTSUB2)**2 +
4217 c    &                        (PPSUB3+PTSUB3)**2 )
4218 c              ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
4219 c    &                        (PPSUB4+PTSUB4+PTSTSU) )
4220 C              WRITE(*,*) ' mother cmE :'
4221 C              WRITE(*,*) ETSTCM,ENEWCM
4222 C              WRITE(*,*) ' subsystem cmE :'
4223 C              WRITE(*,*) ETSTSU,ENEWSU
4224 C              WRITE(*,*) ' projectile mother :'
4225 C              WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
4226 C              WRITE(*,*) ' target mother :'
4227 C              WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
4228 C              WRITE(*,*) ' projectile subsystem:'
4229 C              WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
4230 C              WRITE(*,*) ' target subsystem:'
4231 C              WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
4232 C              WRITE(*,*) ' projectile subsystem should be:'
4233 C              WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
4234 C    &                    XPSUB*ETSTCM/2.0D0
4235 C              WRITE(*,*) ' target subsystem should be:'
4236 C              WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
4237 C    &                    XTSUB*ETSTCM/2.0D0
4238 C              WRITE(*,*) ' subsystem cmE should be: '
4239 C              WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
4240 ***
4241 *
4242 *     generate complete remnant - nucleon/remnant event with PHOJET
4243
4244                CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
4245
4246 *
4247 *     copy back original settings of PHOJET process flags
4248                DO 11 K=1,11
4249                   IPRON(K,1) = KPRON(K)
4250    11          CONTINUE
4251 *
4252 *     check if PHOJET has rejected this event
4253                IF (IREJ1.NE.0) THEN
4254                   IF (IOULEV(1).GT.0)
4255      &            WRITE(LOUT,'(1X,A)') 'EVENTB:  chain system rejected'
4256                   WRITE(LOUT,*)
4257      &                 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
4258
4259                   CALL PHO_PREVNT(0)
4260
4261                   GOTO 9999
4262                ENDIF
4263 *
4264 *     copy partons and strings from PHOJET common back into DTEVT for
4265 *     external fragmentation
4266                MO1 = NC
4267                MO2 = NC+3
4268 *!      uncomment this line for internal phojet-fragmentation
4269 C              CALL DT_GETFSP(MO1,MO2,PP,PT,1)
4270                NPHOSC = NPHOSC+1
4271                CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
4272                IF (IREJ1.NE.0) THEN
4273                   IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
4274      &               'EVENTB: chain system rejected 2'
4275                   GOTO 9999
4276                ENDIF
4277 *
4278 *     update statistics counter
4279                ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
4280 *
4281 *-----------------------------------------------------------------------
4282 * two-chain approx. for smaller systems
4283 *
4284             ELSE
4285 *
4286                NDTUSC = NDTUSC+1
4287 *   special flag for double-Pomeron statistics
4288                IPOPO = 0
4289 *
4290 *   pick up flavors at the ends of the two chains
4291                IFP1 = IDHKK(NC)
4292                IFT1 = IDHKK(NC+1)
4293                IFP2 = IDHKK(NC+2)
4294                IFT2 = IDHKK(NC+3)
4295 *   ..and the indices of the mothers
4296                MOP1 = NC
4297                MOT1 = NC+1
4298                MOP2 = NC+2
4299                MOT2 = NC+3
4300                CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4301      &                     IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4302 *
4303 *   check if this chain system was rejected
4304                IF (IREJ1.GT.0) THEN
4305                   IF (IOULEV(1).GT.0) THEN
4306                      WRITE(LOUT,*) 'rejected 1 in EVENTB'
4307                      WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4308      &                  IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4309                   ENDIF
4310                   IRHHA = IRHHA+1
4311                   GOTO 9999
4312                ENDIF
4313 *   the following lines are for sea-sea chains rejected in GETCSY
4314                IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4315                ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4316             ENDIF
4317 *
4318          ENDIF
4319 *
4320 *     update statistics counter
4321          ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4322 *
4323          NC = NC+4
4324 *
4325     2 CONTINUE
4326 *
4327 *-----------------------------------------------------------------------
4328 * treatment of low-mass chains (if there are any)
4329 *
4330       IF (NDTUSC.GT.0) THEN
4331 *
4332 *   correct chains of very low masses for possible resonances
4333          IF (IRESCO.EQ.1) THEN
4334             CALL DT_EVTRES(IREJ1)
4335             IF (IREJ1.GT.0) THEN
4336                IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4337                IRRES(1) = IRRES(1)+1
4338                GOTO 9999
4339             ENDIF
4340          ENDIF
4341 *   fragmentation of low-mass chains
4342 *!  uncomment this line for internal phojet-fragmentation
4343 *   (of course it will still be fragmented by DPMJET-routines but it
4344 *    has to be done here instead of further below)
4345 C        CALL DT_EVTFRA(IREJ1)
4346 C        IF (IREJ1.GT.0) THEN
4347 C           IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4348 C           IRFRAG = IRFRAG+1
4349 C           GOTO 9999
4350 C        ENDIF
4351       ELSE
4352 *! uncomment this line for internal phojet-fragmentation
4353 C        NPOINT(4) = NHKK+1
4354          IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4355       ENDIF
4356 *
4357 *-----------------------------------------------------------------------
4358 * new di-quark breaking mechanisms
4359 *
4360       MXLEFT = 2
4361       CALL DT_CHASTA(0)
4362       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4363      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
4364          CALL DT_DIQBRK
4365          MXLEFT = 4
4366       ENDIF
4367 *
4368 *-----------------------------------------------------------------------
4369 * hadronize this event
4370 *
4371 *   hadronize PHOJET chain systems
4372       NPYMAX = 0
4373       NPJE   = NPHOSC/MXPHFR
4374       IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4375       IF (NPJE.GT.1) THEN
4376          NLEFT = NPHOSC-NPJE*MXPHFR
4377          DO 20 JFRG=1,NPJE
4378             NFRG = JFRG*MXPHFR
4379             IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4380                CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4381                IF (IREJ1.GT.0) GOTO 22
4382                NLEFT = 0
4383             ELSE
4384                CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4385                IF (IREJ1.GT.0) GOTO 22
4386             ENDIF
4387             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4388    20    CONTINUE
4389          IF (NLEFT.GT.0) THEN
4390             CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4391             IF (IREJ1.GT.0) GOTO 22
4392             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4393          ENDIF
4394       ELSE
4395          CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4396          IF (IREJ1.GT.0) GOTO 22
4397          IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4398       ENDIF
4399 *
4400 *   check max. filling level of jetset common and
4401 *   reduce mxphfr if necessary
4402       IF (NPYMAX.GT.3000) THEN
4403          IF (NPYMAX.GT.3500) THEN
4404             MXPHFR = MAX(1,MXPHFR-2)
4405          ELSE
4406             MXPHFR = MAX(1,MXPHFR-1)
4407          ENDIF
4408 C        WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4409       ENDIF
4410 *
4411 *   hadronize DTUNUC chain systems
4412    23 CONTINUE
4413       IBACK = MXDTFR
4414       CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4415       IF (IREJ2.GT.0) GOTO 22
4416 *
4417 *   check max. filling level of jetset common and
4418 *   reduce mxdtfr if necessary
4419       IF (NPYMEM.GT.3000) THEN
4420          IF (NPYMEM.GT.3500) THEN
4421             MXDTFR = MAX(1,MXDTFR-20)
4422          ELSE
4423             MXDTFR = MAX(1,MXDTFR-10)
4424          ENDIF
4425 C        WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4426       ENDIF
4427 *
4428       IF (IBACK.EQ.-1) GOTO 23
4429 *
4430    22 CONTINUE
4431 C     CALL DT_EVTFRG(1,IREJ1)
4432 C     CALL DT_EVTFRG(2,IREJ2)
4433       IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4434          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4435          IRFRAG = IRFRAG+1
4436          GOTO 9999
4437       ENDIF
4438 *
4439 * get final state particles from /DTEVTP/
4440 *! uncomment this line for internal phojet-fragmentation
4441 C     CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4442
4443       IF (IJPROJ.NE.7)
4444      &   CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4445 C     IF (IREJ3.NE.0) GOTO 9999
4446
4447       RETURN
4448
4449  9999 CONTINUE
4450       IREVT = IREVT+1
4451       IREJ  = 1
4452       RETURN
4453       END
4454
4455 *$ CREATE DT_GETPJE.FOR
4456 *COPY DT_GETPJE
4457 *
4458 *===getpje=============================================================*
4459 *
4460       SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4461
4462 ************************************************************************
4463 * This subroutine copies PHOJET partons and strings from POEVT1 into   *
4464 * DTEVT1.                                                              *
4465 *      MO1,MO2   indices of first and last mother-parton in DTEVT1     *
4466 *      PP,PT     4-momenta of projectile/target being handled by       *
4467 *                PHOJET                                                *
4468 * This version dated 11.12.99 is written by S. Roesler                 *
4469 ************************************************************************
4470
4471       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4472       SAVE
4473
4474       PARAMETER ( LINP = 10 ,
4475      &            LOUT = 6 ,
4476      &            LDAT = 9 )
4477
4478       PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4479      &           ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4480
4481       LOGICAL LFLIP
4482
4483 * event history
4484
4485       PARAMETER (NMXHKK=200000)
4486
4487       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4488      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4489      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4490
4491 * extended event history
4492       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4493      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4494      &                IHIST(2,NMXHKK)
4495
4496 * Lorentz-parameters of the current interaction
4497       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4498      &                UMO,PPCM,EPROJ,PPROJ
4499
4500 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4501       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4502
4503 * flags for input different options
4504       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4505       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4506      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4507
4508 * statistics: double-Pomeron exchange
4509       COMMON /DTFLG2/ INTFLG,IPOPO
4510
4511 * statistics
4512       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4513      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4514      &                ICEVTG(8,0:30)
4515
4516 * rejection counter
4517       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4518      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4519      &                IREXCI(3),IRDIFF(2),IRINC
4520 C  standard particle data interface
4521       INTEGER NMXHEP
4522
4523       PARAMETER (NMXHEP=4000)
4524
4525       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4526       DOUBLE PRECISION PHEP,VHEP
4527       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4528      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4529      &                VHEP(4,NMXHEP)
4530 C  extension to standard particle data interface (PHOJET specific)
4531       INTEGER IMPART,IPHIST,ICOLOR
4532       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4533
4534 C  color string configurations including collapsed strings and hadrons
4535       INTEGER MSTR
4536       PARAMETER (MSTR=500)
4537       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4538       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4539      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4540      &                NNCH(MSTR),IBHAD(MSTR),ISTR
4541
4542 C  general process information
4543       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4544       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4545
4546 C  model switches and parameters
4547       CHARACTER*8 MDLNA
4548       INTEGER ISWMDL,IPAMDL
4549       DOUBLE PRECISION PARMDL
4550       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4551
4552 C  event debugging information
4553       INTEGER NMAXD
4554       PARAMETER (NMAXD=100)
4555       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4556      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4557       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4558      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4559
4560       DIMENSION PP(4),PT(4)
4561       DATA MAXLOP /10000/
4562
4563       INHKK = NHKK
4564       LFLIP = .TRUE.
4565     1 CONTINUE
4566       NPVAL = 0
4567       NTVAL = 0
4568       IREJ  = 0
4569
4570 *   store initial momenta for energy-momentum conservation check
4571       IF (LEMCCK) THEN
4572          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4573          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4574       ENDIF
4575 * copy partons and strings from POEVT1 into DTEVT1
4576       DO 11 I=1,ISTR
4577 C        IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4578          IF (NCODE(I).EQ.-99) THEN
4579             IDXSTG = NPOS(1,I)
4580             IDSTG  = IDHEP(IDXSTG)
4581             PX = PHEP(1,IDXSTG)
4582             PY = PHEP(2,IDXSTG)
4583             PZ = PHEP(3,IDXSTG)
4584             PE = PHEP(4,IDXSTG)
4585             IF (MODE.LT.0) THEN
4586                ISTAT = 70000+IPJE
4587                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4588      &                        11,IDSTG,0)
4589                IF (LEMCCK) THEN
4590                   PX = -PX
4591                   PY = -PY
4592                   PZ = -PZ
4593                   PE = -PE
4594                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4595                ENDIF
4596             ELSE
4597                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4598      &                        PPX,PPY,PPZ,PPE)
4599                ISTAT = 70000+IPJE
4600                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4601      &                        11,IDSTG,0)
4602                IF (LEMCCK) THEN
4603                   PX = -PPX
4604                   PY = -PPY
4605                   PZ = -PPZ
4606                   PE = -PPE
4607                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4608                ENDIF
4609             ENDIF
4610             NOBAM(NHKK)   = 0
4611             IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4612             IHIST(2,NHKK) = 0
4613          ELSEIF (NCODE(I).GE.0) THEN
4614 *   indices of partons and string in POEVT1
4615             IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4616             IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4617             IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4618                WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4619      &         ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4620                STOP ' GETPJE 1'
4621             ENDIF
4622             IDXSTG = NPOS(1,I)
4623 *   find "mother" string of the string
4624             IDXMS1 = ABS(JMOHEP(1,IDX1))
4625             IDXMS2 = ABS(JMOHEP(1,IDX2))
4626             IF (IDXMS1.NE.IDXMS2) THEN
4627                IDXMS1 = IDXSTG
4628                IDXMS2 = IDXSTG
4629 C              STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4630             ENDIF
4631 *   search POEVT1 for the original hadron of the parton
4632             ILOOP = 0
4633             IPOM1 = 0
4634    14       CONTINUE
4635             ILOOP = ILOOP+1
4636
4637             IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4638
4639             IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4640             IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4641      &          (ILOOP.LT.MAXLOP)) GOTO 14
4642             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4643             IPOM2 = 0
4644             ILOOP = 0
4645    15       CONTINUE
4646             ILOOP = ILOOP+1
4647
4648             IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4649
4650             IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4651                IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4652             ELSE
4653                IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4654             ENDIF
4655             IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4656      &          (ILOOP.LT.MAXLOP)) GOTO 15
4657             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4658 *   parton 1
4659             IF (IDXMS1.EQ.1) THEN
4660                ISPTN1 = ISTHKK(MO1)
4661                M1PTN1 = MO1
4662                M2PTN1 = MO1+2
4663             ELSE
4664                ISPTN1 = ISTHKK(MO2)
4665                M1PTN1 = MO2-2
4666                M2PTN1 = MO2
4667             ENDIF
4668 *   parton 2
4669             IF (IDXMS2.EQ.1) THEN
4670                ISPTN2 = ISTHKK(MO1)
4671                M1PTN2 = MO1
4672                M2PTN2 = MO1+2
4673             ELSE
4674                ISPTN2 = ISTHKK(MO2)
4675                M1PTN2 = MO2-2
4676                M2PTN2 = MO2
4677             ENDIF
4678 *   check for mis-identified mothers and switch mother indices if necessary
4679             IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4680      &          .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4681      &          (LFLIP)) THEN
4682                IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4683                   ISPTN1 = ISTHKK(MO1)
4684                   M1PTN1 = MO1
4685                   M2PTN1 = MO1+2
4686                   ISPTN2 = ISTHKK(MO2)
4687                   M1PTN2 = MO2-2
4688                   M2PTN2 = MO2
4689                ELSE
4690                   ISPTN1 = ISTHKK(MO2)
4691                   M1PTN1 = MO2-2
4692                   M2PTN1 = MO2
4693                   ISPTN2 = ISTHKK(MO1)
4694                   M1PTN2 = MO1
4695                   M2PTN2 = MO1+2
4696                ENDIF
4697             ENDIF
4698 *   register partons in temporary common
4699 *     parton at chain end
4700             PX = PHEP(1,IDX1)
4701             PY = PHEP(2,IDX1)
4702             PZ = PHEP(3,IDX1)
4703             PE = PHEP(4,IDX1)
4704 * flag only partons coming from Pomeron with 41/42
4705 C           IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4706             IF (IPOM1.NE.0) THEN
4707                ISTX = ABS(ISPTN1)/10
4708                IMO  = ABS(ISPTN1)-10*ISTX
4709                ISPTN1 = -(40+IMO)
4710             ELSE
4711                IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4712                   ISTX = ABS(ISPTN1)/10
4713                   IMO  = ABS(ISPTN1)-10*ISTX
4714                   IF ((IDHEP(IDX1).EQ.21).OR.
4715      &                (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4716                      ISPTN1 = -(60+IMO)
4717                   ELSE
4718                      ISPTN1 = -(50+IMO)
4719                   ENDIF
4720                ENDIF
4721             ENDIF
4722             IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4723             IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4724             IF (MODE.LT.0) THEN
4725                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4726      &                        PZ,PE,0,0,0)
4727             ELSE
4728                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4729      &                        PPX,PPY,PPZ,PPE)
4730                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4731      &                        PPZ,PPE,0,0,0)
4732             ENDIF
4733             IHIST(1,NHKK) = IPHIST(1,IDX1)
4734             IHIST(2,NHKK) = 0
4735             DO 19 KK=1,4
4736                VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4737                WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4738    19       CONTINUE
4739             VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4740             WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4741             M1STRG = NHKK
4742 *     gluon kinks
4743             NGLUON = IDX2-IDX1-1
4744             IF (NGLUON.GT.0) THEN
4745                DO 17 IGLUON=1,NGLUON
4746                   IDX   = IDX1+IGLUON
4747                   IDXMS = ABS(JMOHEP(1,IDX))
4748                   IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4749                      ILOOP = 0
4750    16                CONTINUE
4751                      ILOOP = ILOOP+1
4752                      IDXMS = ABS(JMOHEP(1,IDXMS))
4753                      IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4754      &                   (ILOOP.LT.MAXLOP)) GOTO 16
4755                      IF (ILOOP.EQ.MAXLOP)
4756      &                  WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4757                   ENDIF
4758                   IF (IDXMS.EQ.1) THEN
4759                      ISPTN = ISTHKK(MO1)
4760                      M1PTN = MO1
4761                      M2PTN = MO1+2
4762                   ELSE
4763                      ISPTN = ISTHKK(MO2)
4764                      M1PTN = MO2-2
4765                      M2PTN = MO2
4766                   ENDIF
4767                   PX = PHEP(1,IDX)
4768                   PY = PHEP(2,IDX)
4769                   PZ = PHEP(3,IDX)
4770                   PE = PHEP(4,IDX)
4771                   IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4772                      ISTX = ABS(ISPTN)/10
4773                      IMO  = ABS(ISPTN)-10*ISTX
4774                      IF ((IDHEP(IDX).EQ.21).OR.
4775      &                   (ABS(IPHIST(1,IDX)).GE.100)) THEN
4776                         ISPTN = -(60+IMO)
4777                      ELSE
4778                         ISPTN = -(50+IMO)
4779                      ENDIF
4780                   ENDIF
4781                   IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4782                   IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4783                   IF (MODE.LT.0) THEN
4784                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4785      &                              PX,PY,PZ,PE,0,0,0)
4786                   ELSE
4787                      CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4788      &                              PPX,PPY,PPZ,PPE)
4789                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4790      &                              PPX,PPY,PPZ,PPE,0,0,0)
4791                   ENDIF
4792                   IHIST(1,NHKK) = IPHIST(1,IDX)
4793                   IHIST(2,NHKK) = 0
4794                   DO 20 KK=1,4
4795                      VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4796                      WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4797    20             CONTINUE
4798                   VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4799                   WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4800    17          CONTINUE
4801             ENDIF
4802 *     parton at chain end
4803             PX = PHEP(1,IDX2)
4804             PY = PHEP(2,IDX2)
4805             PZ = PHEP(3,IDX2)
4806             PE = PHEP(4,IDX2)
4807 * flag only partons coming from Pomeron with 41/42
4808 C           IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4809             IF (IPOM2.NE.0) THEN
4810                ISTX = ABS(ISPTN2)/10
4811                IMO  = ABS(ISPTN2)-10*ISTX
4812                ISPTN2 = -(40+IMO)
4813             ELSE
4814                IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4815                   ISTX = ABS(ISPTN2)/10
4816                   IMO  = ABS(ISPTN2)-10*ISTX
4817                   IF ((IDHEP(IDX2).EQ.21).OR.
4818      &                (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4819                      ISPTN2 = -(60+IMO)
4820                   ELSE
4821                      ISPTN2 = -(50+IMO)
4822                   ENDIF
4823                ENDIF
4824             ENDIF
4825             IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4826             IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4827             IF (MODE.LT.0) THEN
4828                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4829      &                        PX,PY,PZ,PE,0,0,0)
4830             ELSE
4831                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4832      &                        PPX,PPY,PPZ,PPE)
4833                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4834      &                        PPX,PPY,PPZ,PPE,0,0,0)
4835             ENDIF
4836             IHIST(1,NHKK) = IPHIST(1,IDX2)
4837             IHIST(2,NHKK) = 0
4838             DO 21 KK=1,4
4839                VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4840                WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4841    21       CONTINUE
4842             VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4843             WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4844             M2STRG = NHKK
4845 *   register string
4846             JSTRG = 100*IPROCE+NCODE(I)
4847             PX = PHEP(1,IDXSTG)
4848             PY = PHEP(2,IDXSTG)
4849             PZ = PHEP(3,IDXSTG)
4850             PE = PHEP(4,IDXSTG)
4851             IF (MODE.LT.0) THEN
4852                ISTAT = 70000+IPJE
4853                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4854      &                        PX,PY,PZ,PE,0,0,0)
4855                IF (LEMCCK) THEN
4856                   PX = -PX
4857                   PY = -PY
4858                   PZ = -PZ
4859                   PE = -PE
4860                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4861                ENDIF
4862             ELSE
4863                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4864      &                        PPX,PPY,PPZ,PPE)
4865                ISTAT = 70000+IPJE
4866                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4867      &                        PPX,PPY,PPZ,PPE,0,0,0)
4868                IF (LEMCCK) THEN
4869                   PX = -PPX
4870                   PY = -PPY
4871                   PZ = -PPZ
4872                   PE = -PPE
4873                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4874                ENDIF
4875             ENDIF
4876             NOBAM(NHKK)   = 0
4877             IHIST(1,NHKK) = 0
4878             IHIST(2,NHKK) = 0
4879             DO 18 KK=1,4
4880                VHKK(KK,NHKK) = VHKK(KK,MO2)
4881                WHKK(KK,NHKK) = WHKK(KK,MO1)
4882    18       CONTINUE
4883             VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4884             WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4885          ENDIF
4886    11 CONTINUE
4887
4888       IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4889          NHKK  = INHKK
4890          LFLIP = .FALSE.
4891          GOTO 1
4892       ENDIF
4893
4894       IF (LEMCCK) THEN
4895          IF (UMO.GT.1.0D5) THEN
4896             CHKLEV = 1.0D0
4897          ELSE
4898             CHKLEV = TINY1
4899          ENDIF
4900          CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4901
4902          IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4903
4904       ENDIF
4905
4906 * internal statistics
4907 *   dble-Po statistics.
4908       IF (IPROCE.NE.4) IPOPO = 0
4909
4910       INTFLG = IPROCE
4911       IDCHSY = IDCH(MO1)
4912       IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4913          ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4914       ELSE
4915          WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4916  1000    FORMAT(1X,'GETFSP:   warning! incons. process id. (',I2,
4917      &          ') at evt(chain) ',I6,'(',I2,')')
4918       ENDIF
4919       IF (IPROCE.EQ.5) THEN
4920          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4921             ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4922          ELSE
4923 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4924  1001       FORMAT(1X,'GETFSP:   warning! incons. diffrac. id. ',
4925      &             '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4926          ENDIF
4927       ELSEIF (IPROCE.EQ.6) THEN
4928          IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4929             ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4930          ELSE
4931 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4932          ENDIF
4933       ELSEIF (IPROCE.EQ.7) THEN
4934          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4935      &       (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4936             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4937      &         ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4938             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4939      &         ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4940             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4941      &         ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4942             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4943      &         ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4944          ELSE
4945             WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4946          ENDIF
4947       ENDIF
4948       IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4949      &                                                       THEN
4950          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4951          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4952          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4953       ENDIF
4954       ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4955       ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4956       ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4957       ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4958       ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4959
4960       RETURN
4961
4962  9999 CONTINUE
4963       IREJ = 1
4964       RETURN
4965       END
4966
4967 *$ CREATE DT_PHOINI.FOR
4968 *COPY DT_PHOINI
4969 *
4970 *===phoini=============================================================*
4971 *
4972       SUBROUTINE DT_PHOINI
4973
4974 ************************************************************************
4975 * Initialization PHOJET-event generator for nucleon-nucleon interact.  *
4976 * This version dated 16.11.95 is written by S. Roesler                 *
4977 *                                                                      *
4978 * Last change 27.12.2006 by S. Roesler.                                *
4979 ************************************************************************
4980
4981       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4982       SAVE
4983
4984       PARAMETER ( LINP = 10 ,
4985      &            LOUT = 6 ,
4986      &            LDAT = 9 )
4987
4988       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4989
4990 * nucleon-nucleon event-generator
4991       CHARACTER*8 CMODEL
4992       LOGICAL LPHOIN
4993       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4994
4995 * particle properties (BAMJET index convention)
4996       CHARACTER*8  ANAME
4997       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4998      &                IICH(210),IIBAR(210),K1(210),K2(210)
4999
5000 * Lorentz-parameters of the current interaction
5001       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5002      &                UMO,PPCM,EPROJ,PPROJ
5003
5004 * properties of interacting particles
5005       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5006
5007 * properties of photon/lepton projectiles
5008       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5009
5010       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
5011
5012 * emulsion treatment
5013       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
5014      &                NCOMPO,IEMUL
5015
5016 * VDM parameter for photon-nucleus interactions
5017       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
5018
5019 * nuclear potential
5020       LOGICAL LFERMI
5021       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5022      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5023      &                ETACOU(2),ICOUL,LFERMI
5024
5025 * Glauber formalism: flags and parameters for statistics
5026       LOGICAL LPROD
5027       CHARACTER*8 CGLB
5028       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
5029 *
5030 * parameters for cascade calculations:
5031 * maximum mumber of PDF's which can be defined in phojet (limited
5032 * by the dimension of ipdfs in pho_setpdf)
5033       PARAMETER (MAXPDF = 20)
5034 * PDF parametrization and number of set for the first 30 hadrons in
5035 * the bamjet-code list
5036 *   negative numbers mean that the PDF is set in phojet,
5037 *   zero stands for "not a hadron"
5038       DIMENSION IPARPD(30),ISETPD(30)
5039 * PDF parametrization
5040       DATA IPARPD /
5041      &  -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
5042      &   5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
5043 * number of set
5044       DATA ISETPD /
5045      &  -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
5046      &   6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
5047
5048 **PHOJET105a
5049 C     COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
5050 C     PARAMETER ( MAXPRO = 16 )
5051 C     PARAMETER ( MAXTAB = 20 )
5052 C     COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
5053 C    &                MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
5054 C     CHARACTER*8 MDLNA
5055 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
5056 C     COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
5057 **PHOJET110
5058
5059 C  global event kinematics and particle IDs
5060       INTEGER IFPAP,IFPAB
5061       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
5062       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
5063
5064 C  hard cross sections and MC selection weights
5065       INTEGER Max_pro_2
5066       PARAMETER ( Max_pro_2 = 16 )
5067       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
5068      &  MH_acc_1,MH_acc_2
5069       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
5070       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
5071      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
5072      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
5073      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
5074      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
5075
5076 C  model switches and parameters
5077       CHARACTER*8 MDLNA
5078       INTEGER ISWMDL,IPAMDL
5079       DOUBLE PRECISION PARMDL
5080       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
5081
5082 C  general process information
5083       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
5084       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
5085 **
5086       DIMENSION PP(4),PT(4)
5087
5088       LOGICAL LSTART
5089       DATA LSTART /.TRUE./
5090
5091       IJP = IJPROJ
5092       IJT = IJTARG
5093       Q2  = VIRT
5094 * lepton-projectiles: initialize real photon instead
5095       IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
5096          IJP = 7
5097          Q2  = ZERO
5098       ENDIF
5099
5100       IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
5101
5102 * switch Reggeon off
5103 C     IPAMDL(3)= 0
5104       IF (IP.EQ.1) THEN
5105          IFPAP(1) = IDT_IPDGHA(IJP)
5106          IFPAB(1) = IJP
5107       ELSE
5108          IFPAP(1) = 2212
5109          IFPAB(1) = IDT_ICIHAD(IFPAP(1))
5110       ENDIF
5111       PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
5112       PVIRT(1) = PMASS(1)**2
5113       IF (IT.EQ.1) THEN
5114          IFPAP(2) = IDT_IPDGHA(IJT)
5115          IFPAB(2) = IJT
5116       ELSE
5117          IFPAP(2) = 2212
5118          IFPAB(2) = IDT_ICIHAD(IFPAP(2))
5119       ENDIF
5120       PMASS(2) = AAM(IFPAB(2))
5121       PVIRT(2) = ZERO
5122       DO 1 K=1,4
5123          PP(K) = ZERO
5124          PT(K) = ZERO
5125     1 CONTINUE
5126 * get max. possible momenta of incoming particles to be used for PHOJET ini.
5127       PPF = ZERO
5128       PTF = ZERO
5129       SCPF= 1.5D0
5130       IF (UMO.GE.1.E5) THEN
5131          SCPF= 5.0D0
5132       ENDIF
5133       IF (NCOMPO.GT.0) THEN
5134          DO 2 I=1,NCOMPO
5135             IF (IT.GT.1) THEN
5136                CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
5137             ELSE
5138                CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
5139             ENDIF
5140             PPFTMP = MAX(PFERMP(1),PFERMN(1))
5141             PTFTMP = MAX(PFERMP(2),PFERMN(2))
5142             IF (PPFTMP.GT.PPF) PPF = PPFTMP
5143             IF (PTFTMP.GT.PTF) PTF = PTFTMP
5144     2    CONTINUE
5145       ELSE
5146          CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
5147          PPF = MAX(PFERMP(1),PFERMN(1))
5148          PTF = MAX(PFERMP(2),PFERMN(2))
5149       ENDIF
5150       PTF = -PTF
5151       PPF = SCPF*PPF
5152       PTF = SCPF*PTF
5153       IF (IJP.EQ.7) THEN
5154          AMP2  = SIGN(PMASS(1)**2,PMASS(1))
5155          PP(3) = PPCM
5156          PP(4) = SQRT(AMP2+PP(3)**2)
5157       ELSE
5158          EPF = SQRT(PPF**2+PMASS(1)**2)
5159          CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
5160       ENDIF
5161       ETF = SQRT(PTF**2+PMASS(2)**2)
5162       CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
5163       ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
5164      &              (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
5165       IF (LSTART) THEN
5166          WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
5167  1001    FORMAT(
5168      &      ' DT_PHOINI:    PHOJET initialized for projectile A,Z = ',
5169      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
5170          IF (NCOMPO.GT.0) THEN
5171             WRITE(LOUT,1002) SCPF,PTF,PT
5172          ELSE
5173             WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
5174          ENDIF
5175  1002    FORMAT(
5176      &      ' DT_PHOINI:    PHOJET initialized for target emulsion  ',
5177      &          /,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
5178  1003    FORMAT(
5179      &      ' DT_PHOINI:    PHOJET initialized for target     A,Z = ',
5180      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
5181          WRITE(LOUT,1004) ECMINI
5182  1004    FORMAT(' E_cm = ',E10.3)
5183          IF (IJP.EQ.8) WRITE(LOUT,1005)
5184  1005    FORMAT(
5185      &      ' DT_PHOINI: warning! proton parameters used for neutron',
5186      &          ' projectile')
5187          LSTART = .FALSE.
5188       ENDIF
5189 * switch off new diffractive cross sections at low energies for nuclei
5190 * (temporary solution)
5191       IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
5192          WRITE(LOUT,'(1X,A)')
5193      &      ' DT_PHOINI: model-switch 30 for nuclei re-set !'
5194          CALL PHO_SETMDL(30,0,1)
5195       ENDIF
5196 *
5197 C     IF (IJP.EQ.7) THEN
5198 C        AMP2  = SIGN(PMASS(1)**2,PMASS(1))
5199 C        PP(3) = PPCM
5200 C        PP(4) = SQRT(AMP2+PP(3)**2)
5201 C     ELSE
5202 C        PFERMX = ZERO
5203 C        IF (IP.GT.1) PFERMX = 0.5D0
5204 C        EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
5205 C        CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
5206 C     ENDIF
5207 C     PFERMX = ZERO
5208 C     IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
5209 C     EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
5210 C     CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
5211 **sr 26.10.96
5212       ISAV = IPAMDL(13)
5213       IF ((ISHAD(2).EQ.1).AND.
5214      &   ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
5215      &    (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
5216 **
5217
5218       CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
5219
5220 **sr 26.10.96
5221       IPAMDL(13) = ISAV
5222 **
5223 *
5224 * patch for cascade calculations:
5225 * define parton distribution functions for other hadrons, i.e. other
5226 * then defined already in phojet
5227       IF (IOGLB.EQ.100) THEN
5228          WRITE(LOUT,1006)
5229  1006    FORMAT(/,1X,'PHOINI: additional parton distribution functions',
5230      &          ' assiged (ID,IPAR,ISET)',/)
5231          NPDF = 0
5232          DO 3 I=1,30
5233             IF (IPARPD(I).NE.0) THEN
5234                NPDF = NPDF+1
5235                IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
5236                IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
5237                   IDPDG = IDT_IPDGHA(I)
5238                   IPAR  = IPARPD(I)
5239                   ISET  = ISETPD(I)
5240                   WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
5241                   CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
5242                ENDIF
5243             ENDIF
5244     3    CONTINUE
5245       ENDIF
5246
5247 C     CALL PHO_PHIST(-1,SIGMAX)
5248
5249       IF (IREJ1.NE.0) THEN
5250          WRITE(LOUT,1000)
5251  1000    FORMAT(1X,'PHOINI:   PHOJET event-initialization failed!')
5252          STOP
5253       ENDIF
5254
5255       RETURN
5256       END
5257
5258 *$ CREATE DT_EVENTD.FOR
5259 *COPY DT_EVENTD
5260 *
5261 *===eventd=============================================================*
5262 *
5263       SUBROUTINE DT_EVENTD(IREJ)
5264
5265 ************************************************************************
5266 * Quasi-elastic neutrino nucleus scattering.                           *
5267 * This version dated 29.04.00 is written by S. Roesler.                *
5268 ************************************************************************
5269
5270       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5271       SAVE
5272
5273       PARAMETER ( LINP = 10 ,
5274      &            LOUT = 6 ,
5275      &            LDAT = 9 )
5276
5277       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
5278       PARAMETER (SQTINF=1.0D+15)
5279
5280       LOGICAL LFIRST
5281
5282 * event history
5283
5284       PARAMETER (NMXHKK=200000)
5285
5286       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5287      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5288      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5289
5290 * extended event history
5291       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5292      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5293      &                IHIST(2,NMXHKK)
5294
5295 * flags for input different options
5296       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5297       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5298      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5299       PARAMETER (MAXLND=4000)
5300       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
5301
5302 * properties of interacting particles
5303       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5304
5305 * Lorentz-parameters of the current interaction
5306       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5307      &                UMO,PPCM,EPROJ,PPROJ
5308
5309 * nuclear potential
5310       LOGICAL LFERMI
5311       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5312      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5313      &                ETACOU(2),ICOUL,LFERMI
5314
5315 * steering flags for qel neutrino scattering modules
5316       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
5317
5318       COMMON /QNPOL/ POLARX(4),PMODUL
5319
5320       INTEGER PYK
5321
5322       DATA LFIRST /.TRUE./
5323
5324       IREJ = 0
5325
5326       IF (LFIRST) THEN
5327          LFIRST = .FALSE.
5328          CALL DT_MASS_INI
5329       ENDIF
5330
5331 * JETSET parameter
5332       CALL DT_INITJS(0)
5333
5334 * interacting target nucleon
5335       LTYP = NEUTYP
5336       IF (NEUDEC.LE.9) THEN
5337          IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5338             NUCTYP = 2112
5339             NUCTOP = 2
5340          ELSE
5341             NUCTYP = 2212
5342             NUCTOP = 1
5343          ENDIF
5344       ELSE
5345          RTYP  = DT_RNDM(RTYP)
5346          ZFRAC = DBLE(ITZ)/DBLE(IT)
5347          IF (RTYP.LE.ZFRAC) THEN
5348             NUCTYP = 2212
5349             NUCTOP = 1
5350          ELSE
5351             NUCTYP = 2112
5352             NUCTOP = 2
5353          ENDIF
5354       ENDIF
5355
5356 * select first nucleon in list with matching id and reset all other
5357 * nucleons which have been marked as "wounded" by ININUC
5358       IFOUND = 0
5359       DO 1 I=1,NHKK
5360          IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5361             ISTHKK(I) = 12
5362             IFOUND    = 1
5363             IDX = I
5364          ELSE
5365             IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5366          ENDIF
5367     1 CONTINUE
5368       IF (IFOUND.EQ.0)
5369      &   STOP ' EVENTD: interacting target nucleon not found! '
5370
5371 * correct position of proj. lepton: assume position of target nucleon
5372       DO 3 I=1,4
5373          VHKK(I,1) = VHKK(I,IDX)
5374          WHKK(I,1) = WHKK(I,IDX)
5375     3 CONTINUE
5376
5377 * load initial momenta for conservation check
5378       IF (LEMCCK) THEN
5379          CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5380          CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5381      &                                                      2,IDUM,IDUM)
5382       ENDIF
5383
5384 * quasi-elastic scattering
5385       IF (NEUDEC.LT.9) THEN
5386          CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5387      &                                          PHKK(4,IDX),PHKK(5,IDX))
5388 *  CC event on p or n
5389       ELSEIF (NEUDEC.EQ.10) THEN
5390          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5391      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5392 *  NC event on p or n
5393       ELSEIF (NEUDEC.EQ.11) THEN
5394          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5395      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5396       ENDIF
5397
5398 * get final state particles from Lund-common and write them into HKKEVT
5399       NPOINT(1) = NHKK+1
5400       NPOINT(4) = NHKK+1
5401
5402       NLINES = PYK(0,1)
5403
5404       NHKK0  = NHKK+1
5405       DO 4 I=4,NLINES
5406          IF (K(I,1).EQ.1) THEN
5407             ID = K(I,2)
5408             PX = P(I,1)
5409             PY = P(I,2)
5410             PZ = P(I,3)
5411             PE = P(I,4)
5412             CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5413             IDBJ = IDT_ICIHAD(ID)
5414             EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5415             IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5416                IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5417             ENDIF
5418             VHKK(1,NHKK) = VHKK(1,IDX)
5419             VHKK(2,NHKK) = VHKK(2,IDX)
5420             VHKK(3,NHKK) = VHKK(3,IDX)
5421             VHKK(4,NHKK) = VHKK(4,IDX)
5422 C           IF (I.EQ.4) THEN
5423 C              WHKK(1,NHKK) = POLARX(1)
5424 C              WHKK(2,NHKK) = POLARX(2)
5425 C              WHKK(3,NHKK) = POLARX(3)
5426 C              WHKK(4,NHKK) = POLARX(4)
5427 C           ELSE
5428                WHKK(1,NHKK) = WHKK(1,IDX)
5429                WHKK(2,NHKK) = WHKK(2,IDX)
5430                WHKK(3,NHKK) = WHKK(3,IDX)
5431                WHKK(4,NHKK) = WHKK(4,IDX)
5432 C           ENDIF
5433             IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5434          ENDIF
5435     4 CONTINUE
5436
5437       IF (LEMCCK) THEN
5438          CHKLEV = TINY5
5439          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5440          IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5441       ENDIF
5442
5443 * transform momenta into cms (as required for inc etc.)
5444       DO 5 I=NHKK0,NHKK
5445          IF (ISTHKK(I).EQ.1) THEN
5446             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5447             PHKK(3,I) = PZ
5448             PHKK(4,I) = PE
5449          ENDIF
5450     5 CONTINUE
5451
5452       RETURN
5453       END
5454 *$ CREATE DT_KKEVNT.FOR
5455 *COPY DT_KKEVNT
5456 *
5457 *===kkevnt=============================================================*
5458 *
5459       SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5460
5461 ************************************************************************
5462 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering   *
5463 * without nuclear effects (one event).                                 *
5464 * This subroutine is an update of the previous version (KKEVT) written *
5465 * by J. Ranft/ H.-J. Moehring.                                         *
5466 * This version dated 20.04.95 is written by S. Roesler                 *
5467 ************************************************************************
5468
5469       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5470       SAVE
5471
5472       PARAMETER ( LINP = 10 ,
5473      &            LOUT = 6 ,
5474      &            LDAT = 9 )
5475
5476       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5477
5478       PARAMETER ( MAXNCL = 260,
5479
5480      &            MAXVQU = MAXNCL,
5481      &            MAXSQU = 20*MAXVQU,
5482      &            MAXINT = MAXVQU+MAXSQU)
5483
5484 * event history
5485
5486       PARAMETER (NMXHKK=200000)
5487
5488       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5489      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5490      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5491
5492 * extended event history
5493       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5494      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5495      &                IHIST(2,NMXHKK)
5496
5497 * flags for input different options
5498       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5499       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5500      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5501
5502 * rejection counter
5503       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5504      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5505      &                IREXCI(3),IRDIFF(2),IRINC
5506
5507 * statistics
5508       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5509      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5510      &                ICEVTG(8,0:30)
5511
5512 * properties of interacting particles
5513       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5514
5515 * Lorentz-parameters of the current interaction
5516       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5517      &                UMO,PPCM,EPROJ,PPROJ
5518
5519 * flags for diffractive interactions (DTUNUC 1.x)
5520       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5521
5522 * interface HADRIN-DPM
5523       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5524
5525 * nucleon-nucleon event-generator
5526       CHARACTER*8 CMODEL
5527       LOGICAL LPHOIN
5528       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5529
5530 * coordinates of nucleons
5531       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5532
5533 * interface between Glauber formalism and DPM
5534       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5535      &                INTER1(MAXINT),INTER2(MAXINT)
5536
5537 * Glauber formalism: collision properties
5538       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5539      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5540      &                NCP,NCT
5541
5542 * central particle production, impact parameter biasing
5543       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5544 **temporary
5545
5546 * statistics: Glauber-formalism
5547       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5548 **
5549
5550       DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5551
5552       IREJ   = 0
5553       ICREQU = ICREQU+1
5554       NC     = 0
5555
5556     1 CONTINUE
5557       ICSAMP = ICSAMP+1
5558       NC     = NC+1
5559       IF (MOD(NC,10).EQ.0) THEN
5560          WRITE(LOUT,1000) NEVHKK
5561  1000    FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5562          GOTO 9999
5563       ENDIF
5564
5565 * initialize DTEVT1/DTEVT2
5566       CALL DT_EVTINI
5567
5568 * We need the following only in order to sample nucleon coordinates.
5569 * However we don't have parameters (cross sections, slope etc.)
5570 * for neutrinos available. Therefore switch projectile to proton
5571 * in this case.
5572       IF (MCGENE.EQ.4) THEN
5573          JJPROJ = 1
5574       ELSE
5575          JJPROJ = IJPROJ
5576       ENDIF
5577
5578    10 CONTINUE
5579       IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5580 * make sure that Glauber-formalism is called each time the interaction
5581 * configuration changed
5582      &     (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5583      &     (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5584 * sample number of nucleon-nucleon coll. according to Glauber-form.
5585          CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5586          NWTSAM = NN
5587          NWASAM = NP
5588          NWBSAM = NT
5589          NEVOLD = NEVHKK
5590          IPOLD  = IP
5591          ITOLD  = IT
5592          JJPOLD = JJPROJ
5593          EPROLD = EPROJ
5594          NCP    = 0
5595          NCT    = 0
5596
5597       DO 8 I=1, IP
5598         NCP = NCP+JSSH(I)
5599 *        WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP
5600     8 CONTINUE
5601       DO 9 I=1, IT
5602         NCT = NCT+JTSH(I)
5603 *        WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT
5604     9 CONTINUE
5605       ENDIF
5606
5607 * force diffractive particle production in h-K interactions
5608       IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5609      &    (IP.EQ.1).AND.(NN.NE.1)) THEN
5610          NEVOLD = 0
5611          GOTO 10
5612       ENDIF
5613
5614 * check number of involved proj. nucl. (NP) if central prod.is requested
5615       IF (ICENTR.GT.0) THEN
5616          CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5617          IF (IBACK.GT.0) GOTO 10
5618       ENDIF
5619
5620 * get initial nucleon-configuration in projectile and target
5621 * rest-system (including Fermi-momenta if requested)
5622       CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5623       MODE = 2
5624       IF (EPROJ.LE.EHADTH) MODE = 3
5625       CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5626
5627       IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5628
5629 * activate HADRIN at low energies (implemented for h-N scattering only)
5630          IF (EPROJ.LE.EHADHI) THEN
5631             IF (EHADTH.LT.ZERO) THEN
5632 *   smooth transition btwn. DPM and HADRIN
5633                FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5634                RR   = DT_RNDM(FRAC)
5635                IF (RR.GT.FRAC) THEN
5636                   IF (IP.EQ.1) THEN
5637                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5638                      IF (IREJ1.GT.0) GOTO 1
5639                      RETURN
5640                   ELSE
5641                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5642                   ENDIF
5643                ENDIF
5644             ELSE
5645 *   fixed threshold for onset of production via HADRIN
5646                IF (EPROJ.LE.EHADTH) THEN
5647                   IF (IP.EQ.1) THEN
5648                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5649                      IF (IREJ1.GT.0) GOTO 1
5650                      RETURN
5651                   ELSE
5652                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5653                   ENDIF
5654                ENDIF
5655             ENDIF
5656          ENDIF
5657  1001    FORMAT(1X,'KKEVNT:   warning! interaction of proj. (m=',
5658      &          I3,') with target (m=',I3,')',/,11X,
5659      &          'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5660      &          'GeV) cannot be handled')
5661
5662 * sampling of momentum-x fractions & flavors of chain ends
5663          CALL DT_SPLPTN(NN)
5664
5665 * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5666          CALL DT_NUC2CM
5667
5668 * collect momenta of chain ends and put them into DTEVT1
5669          CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5670          IF (IREJ1.NE.0) GOTO 1
5671
5672       ENDIF
5673
5674 * handle chains including fragmentation (two-chain approximation)
5675       IF (MCGENE.EQ.1) THEN
5676 *  two-chain approximation
5677          CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5678          IF (IREJ1.NE.0) THEN
5679             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5680             GOTO 1
5681          ENDIF
5682       ELSEIF (MCGENE.EQ.2) THEN
5683 *  multiple-Po exchange including minijets
5684          CALL DT_EVENTB(NCSY,IREJ1)
5685          IF (IREJ1.NE.0) THEN
5686             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5687             GOTO 1
5688          ENDIF
5689       ELSEIF (MCGENE.EQ.3) THEN
5690          STOP ' This version does not contain LEPTO !'
5691
5692       ELSEIF (MCGENE.EQ.4) THEN
5693 *  quasi-elastic neutrino scattering
5694          CALL DT_EVENTD(IREJ1)
5695          IF (IREJ1.NE.0) THEN
5696             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5697             GOTO 1
5698          ENDIF
5699       ELSE
5700          WRITE(LOUT,1002) MCGENE
5701  1002    FORMAT(1X,'KKEVNT:   warning! event-generator',I4,
5702      &         ' not available - program stopped')
5703          STOP
5704       ENDIF
5705
5706       RETURN
5707
5708  9999 CONTINUE
5709       IREJ = 1
5710       RETURN
5711       END
5712
5713 *$ CREATE DT_CHKCEN.FOR
5714 *COPY DT_CHKCEN
5715 *
5716 *===chkcen=============================================================*
5717 *
5718       SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5719
5720 ************************************************************************
5721 * Check of number of involved projectile nucleons if central production*
5722 * is requested.                                                        *
5723 * Adopted from a part of the old KKEVT routine which was written by    *
5724 * J. Ranft/H.-J.Moehring.                                              *
5725 * This version dated 13.01.95 is written by S. Roesler                 *
5726 ************************************************************************
5727
5728       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5729       SAVE
5730
5731       PARAMETER ( LINP = 10 ,
5732      &            LOUT = 6 ,
5733      &            LDAT = 9 )
5734
5735 * statistics
5736       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5737      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5738      &                ICEVTG(8,0:30)
5739
5740 * central particle production, impact parameter biasing
5741       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5742
5743       IBACK = 0
5744
5745 * old version
5746       IF (ICENTR.EQ.2) THEN
5747          IF (IP.LT.IT) THEN
5748             IF (IP.LE.8) THEN
5749                IF (NP.LT.IP-1) IBACK = 1
5750             ELSEIF (IP.LE.16) THEN
5751                IF (NP.LT.IP-2) IBACK = 1
5752             ELSEIF (IP.LE.32) THEN
5753                IF (NP.LT.IP-3) IBACK = 1
5754             ELSEIF (IP.GE.33) THEN
5755                IF (NP.LT.IP-5) IBACK = 1
5756             ENDIF
5757          ELSEIF (IP.EQ.IT) THEN
5758             IF (IP.EQ.32) THEN
5759                IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5760             ELSE
5761                IF (NP.LT.IP-IP/8) IBACK = 1
5762             ENDIF
5763          ELSEIF (ABS(IP-IT).LT.3) THEN
5764             IF (NP.LT.IP-IP/8) IBACK = 1
5765          ENDIF
5766       ELSE
5767 * new version (DPMJET, 5.6.99)
5768          IF (IP.LT.IT) THEN
5769             IF (IP.LE.8) THEN
5770                IF (NP.LT.IP-1) IBACK = 1
5771             ELSEIF (IP.LE.16) THEN
5772                IF (NP.LT.IP-2) IBACK = 1
5773             ELSEIF (IP.LT.32) THEN
5774                IF (NP.LT.IP-3) IBACK = 1
5775             ELSEIF (IP.GE.32) THEN
5776                IF (IT.LE.150) THEN
5777 *   Example: S-Ag
5778                   IF (NP.LT.IP-1) IBACK = 1
5779                ELSE
5780 *   Example: S-Au
5781                   IF (NP.LT.IP) IBACK = 1
5782                ENDIF
5783             ENDIF
5784          ELSEIF (IP.EQ.IT) THEN
5785 *   Example: S-S
5786            IF (IP.EQ.32) THEN
5787               IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5788 *   Example: Pb-Pb
5789            ELSE
5790               IF (NP.LT.IP-IP/4) IBACK = 1
5791            ENDIF
5792          ELSEIF (ABS(IP-IT).LT.3) THEN
5793             IF (NP.LT.IP-IP/8) IBACK = 1
5794          ENDIF
5795       ENDIF
5796
5797       ICCPRO = ICCPRO+1
5798
5799       RETURN
5800       END
5801
5802 *$ CREATE DT_ININUC.FOR
5803 *COPY DT_ININUC
5804 *
5805 *===ininuc=============================================================*
5806 *
5807       SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5808
5809 ************************************************************************
5810 * Samples initial configuration of nucleons in nucleus with mass NMASS *
5811 * including Fermi-momenta (if reqested).                               *
5812 *          ID             BAMJET-code for hadrons (instead of nuclei)  *
5813 *          NMASS          mass number of nucleus (number of nucleons)  *
5814 *          NCH            charge of nucleus                            *
5815 *          COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5816 *          JS(NMASS) > 0  nucleon undergoes nucleon-nucleon interact.  *
5817 *          IMODE = 1      projectile nucleus                           *
5818 *                = 2      target     nucleus                           *
5819 *                = 3      target     nucleus (E_lab<E_thr for HADRIN)  *
5820 * Adopted from a part of the old KKEVT routine which was written by    *
5821 * J. Ranft/H.-J.Moehring.                                              *
5822 * This version dated 13.01.95 is written by S. Roesler                 *
5823 ************************************************************************
5824
5825       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5826       SAVE
5827
5828       PARAMETER ( LINP = 10 ,
5829      &            LOUT = 6 ,
5830      &            LDAT = 9 )
5831
5832       PARAMETER (FM2MM=1.0D-12)
5833
5834       PARAMETER ( MAXNCL = 260,
5835
5836      &            MAXVQU = MAXNCL,
5837      &            MAXSQU = 20*MAXVQU,
5838      &            MAXINT = MAXVQU+MAXSQU)
5839
5840 * event history
5841
5842       PARAMETER (NMXHKK=200000)
5843
5844       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5845      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5846      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5847
5848 * extended event history
5849       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5850      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5851      &                IHIST(2,NMXHKK)
5852
5853 * flags for input different options
5854       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5855       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5856      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5857
5858 * auxiliary common for chain system storage (DTUNUC 1.x)
5859       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5860
5861 * nuclear potential
5862       LOGICAL LFERMI
5863       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5864      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5865      &                ETACOU(2),ICOUL,LFERMI
5866
5867 * properties of photon/lepton projectiles
5868       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5869
5870 * particle properties (BAMJET index convention)
5871       CHARACTER*8  ANAME
5872       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5873      &                IICH(210),IIBAR(210),K1(210),K2(210)
5874
5875 * Glauber formalism: collision properties
5876       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5877      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5878      &                NCP,NCT
5879
5880 * flavors of partons (DTUNUC 1.x)
5881       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5882      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5883      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5884      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5885      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5886      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5887      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5888
5889 * interface HADRIN-DPM
5890       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5891
5892       DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5893
5894 * number of neutrons
5895       NNEU = NMASS-NCH
5896 * initializations
5897       NP = 0
5898       NN = 0
5899       DO 1 K=1,4
5900          PFTOT(K) = 0.0D0
5901     1 CONTINUE
5902       MODE   = IMODE
5903       IF (IMODE.GT.2) MODE = 2
5904 **sr 29.5. new NPOINT(1)-definition
5905 C     IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5906 **
5907       NHADRI = 0
5908       NC     = NHKK
5909
5910 * get initial configuration
5911       DO 2 I=1,NMASS
5912          NHKK = NHKK+1
5913          IF (JS(I).GT.0) THEN
5914             ISTHKK(NHKK) = 10+MODE
5915             IF (IMODE.EQ.3) THEN
5916 *   additional treatment if HADRIN-generator is requested
5917                NHADRI = NHADRI+1
5918                IF (NHADRI.EQ.1) IDXTA  = NHKK
5919                IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5920             ENDIF
5921          ELSE
5922             ISTHKK(NHKK) = 12+MODE
5923          ENDIF
5924          IF (NMASS.GE.2) THEN
5925 *   treatment for nuclei
5926             FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5927             RR   = DT_RNDM(FRAC)
5928             IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5929                IDX = 8
5930                NN  = NN+1
5931             ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5932                IDX = 1
5933                NP  = NP+1
5934             ELSEIF (NN.LT.NNEU) THEN
5935                IDX = 8
5936                NN  = NN+1
5937             ELSEIF (NP.LT.NCH)  THEN
5938                IDX = 1
5939                NP  = NP+1
5940             ENDIF
5941             IDHKK(NHKK) = IDT_IPDGHA(IDX)
5942             IDBAM(NHKK) = IDX
5943             IF (MODE.EQ.1) THEN
5944                IPOSP(I)  = NHKK
5945                KKPROJ(I) = IDX
5946             ELSE
5947                IPOST(I)  = NHKK
5948                KKTARG(I) = IDX
5949             ENDIF
5950             IF (IDX.EQ.1) THEN
5951                PFER = PFERMP(MODE)
5952                PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5953             ELSE
5954                PFER = PFERMN(MODE)
5955                PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5956             ENDIF
5957             CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5958             DO 3 K=1,4
5959                PFTOT(K) = PFTOT(K)+PF(K)
5960                PHKK(K,NHKK) = PF(K)
5961     3       CONTINUE
5962             PHKK(5,NHKK) = AAM(IDX)
5963          ELSE
5964 *   treatment for hadrons
5965             IDHKK(NHKK)  = IDT_IPDGHA(ID)
5966             IDBAM(NHKK)  = ID
5967             PHKK(4,NHKK) = AAM(ID)
5968             PHKK(5,NHKK) = AAM(ID)
5969 C* VDM assumption
5970 C            IF (IDHKK(NHKK).EQ.22) THEN
5971 C               PHKK(4,NHKK) = AAM(33)
5972 C               PHKK(5,NHKK) = AAM(33)
5973 C            ENDIF
5974             IF (MODE.EQ.1) THEN
5975                IPOSP(I)  = NHKK
5976                KKPROJ(I) = ID
5977                PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5978             ELSE
5979                IPOST(I)  = NHKK
5980                KKTARG(I) = ID
5981             ENDIF
5982          ENDIF
5983          DO 4 K=1,3
5984             VHKK(K,NHKK) = COORD(K,I)*FM2MM
5985             WHKK(K,NHKK) = COORD(K,I)*FM2MM
5986     4    CONTINUE
5987          IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5988          IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5989          VHKK(4,NHKK) = 0.0D0
5990          WHKK(4,NHKK) = 0.0D0
5991     2 CONTINUE
5992
5993 * balance Fermi-momenta
5994       IF (NMASS.GE.2) THEN
5995          DO 5 I=1,NMASS
5996             NC = NC+1
5997             DO 6 K=1,3
5998                PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5999     6       CONTINUE
6000             PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
6001      &                        PHKK(2,NC)**2+PHKK(3,NC)**2)
6002     5    CONTINUE
6003       ENDIF
6004
6005       RETURN
6006       END
6007
6008 *$ CREATE DT_FER4M.FOR
6009 *COPY DT_FER4M
6010 *
6011 *===fer4m==============================================================*
6012 *
6013       SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
6014
6015 ************************************************************************
6016 * Sampling of nucleon Fermi-momenta from distributions at T=0.         *
6017 *                                   processed by S. Roesler, 17.10.95  *
6018 ************************************************************************
6019
6020       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6021       SAVE
6022
6023       PARAMETER ( LINP = 10 ,
6024      &            LOUT = 6 ,
6025      &            LDAT = 9 )
6026
6027       LOGICAL LSTART
6028
6029 * particle properties (BAMJET index convention)
6030       CHARACTER*8  ANAME
6031       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6032      &                IICH(210),IIBAR(210),K1(210),K2(210)
6033
6034 * nuclear potential
6035       LOGICAL LFERMI
6036       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
6037      &                EBINDP(2),EBINDN(2),EPOT(2,210),
6038      &                ETACOU(2),ICOUL,LFERMI
6039
6040       DATA LSTART /.TRUE./
6041
6042       ILOOP = 0
6043       IF (LFERMI) THEN
6044          IF (LSTART) THEN
6045             WRITE(LOUT,1000)
6046  1000       FORMAT(/,1X,'FER4M:   sampling of Fermi-momenta activated')
6047             LSTART = .FALSE.
6048          ENDIF
6049     1    CONTINUE
6050          CALL DT_DFERMI(PABS)
6051          PABS = PFERM*PABS
6052 C        IF (PABS.GE.PBIND) THEN
6053 C           ILOOP = ILOOP+1
6054 C           IF (MOD(ILOOP,500).EQ.0) THEN
6055 C              WRITE(LOUT,1001) PABS,PBIND,ILOOP
6056 C1001          FORMAT(1X,'FER4M:    Fermi-mom. corr. for binding',
6057 C    &                ' energy ',2E12.3,I6)
6058 C           ENDIF
6059 C           GOTO 1
6060 C        ENDIF
6061          CALL DT_DPOLI(POLC,POLS)
6062          CALL DT_DSFECF(SFE,CFE)
6063          CXTA = POLS*CFE
6064          CYTA = POLS*SFE
6065          CZTA = POLC
6066          ET   = SQRT(PABS*PABS+AAM(KT)**2)
6067          PXT  = CXTA*PABS
6068          PYT  = CYTA*PABS
6069          PZT  = CZTA*PABS
6070       ELSE
6071          ET   = AAM(KT)
6072          PXT  = 0.0D0
6073          PYT  = 0.0D0
6074          PZT  = 0.0D0
6075       ENDIF
6076
6077       RETURN
6078       END
6079
6080 *$ CREATE DT_NUC2CM.FOR
6081 *COPY DT_NUC2CM
6082 *
6083 *===nuc2cm=============================================================*
6084 *
6085       SUBROUTINE DT_NUC2CM
6086
6087 ************************************************************************
6088 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.-   *
6089 * nucl. cms. (This subroutine replaces NUCMOM.)                        *
6090 * This version dated 15.01.95 is written by S. Roesler                 *
6091 ************************************************************************
6092
6093       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6094       SAVE
6095
6096       PARAMETER ( LINP = 10 ,
6097      &            LOUT = 6 ,
6098      &            LDAT = 9 )
6099
6100       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
6101
6102 * event history
6103
6104       PARAMETER (NMXHKK=200000)
6105
6106       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6107      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6108      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6109
6110 * extended event history
6111       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6112      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6113      &                IHIST(2,NMXHKK)
6114
6115 * statistics
6116       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6117      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6118      &                ICEVTG(8,0:30)
6119
6120 * properties of photon/lepton projectiles
6121       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
6122
6123 * particle properties (BAMJET index convention)
6124       CHARACTER*8  ANAME
6125       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6126      &                IICH(210),IIBAR(210),K1(210),K2(210)
6127
6128 * Glauber formalism: collision properties
6129       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
6130      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
6131      &                NCP,NCT
6132 **temporary
6133
6134 * statistics: Glauber-formalism
6135       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
6136 **
6137
6138       ICWP = 0
6139       ICWT = 0
6140       NWTACC = 0
6141       NWAACC = 0
6142       NWBACC = 0
6143
6144       NPOINT(1) = NHKK+1
6145       NEND      = NHKK
6146       DO 1 I=1,NEND
6147          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
6148             IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
6149             IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
6150             MODE = ISTHKK(I)-9
6151 C            IF (IDHKK(I).EQ.22) THEN
6152 C* VDM assumption
6153 C               PEIN = AAM(33)
6154 C               IDB  = 33
6155 C            ELSE
6156 C               PEIN = PHKK(4,I)
6157 C               IDB  = IDBAM(I)
6158 C            ENDIF
6159 C            CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
6160 C     &           PX,PY,PZ,PE,IDB,MODE)
6161             IF (PHKK(5,I).GT.ZERO) THEN
6162                CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
6163      &              PX,PY,PZ,PE,IDBAM(I),MODE)
6164             ELSE
6165                PX = PGAMM(1)
6166                PY = PGAMM(2)
6167                PZ = PGAMM(3)
6168                PE = PGAMM(4)
6169             ENDIF
6170             IST = ISTHKK(I)-2
6171             ID  = IDHKK(I)
6172 C* VDM assumption
6173 C            IF (ID.EQ.22) ID = 113
6174             CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
6175             IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
6176             IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
6177          ENDIF
6178     1 CONTINUE
6179
6180       NWTACC = MAX(NWAACC,NWBACC)
6181       ICDPR  = ICDPR+ICWP
6182       ICDTA  = ICDTA+ICWT
6183 **temporary
6184       IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
6185          CALL DT_EVTOUT(4)
6186          STOP
6187       ENDIF
6188
6189       RETURN
6190       END
6191
6192 *$ CREATE DT_SPLPTN.FOR
6193 *COPY DT_SPLPTN
6194 *
6195 *===splptn=============================================================*
6196 *
6197       SUBROUTINE DT_SPLPTN(NN)
6198
6199 ************************************************************************
6200 * SamPLing of ParToN momenta and flavors.                              *
6201 * This version dated 15.01.95 is written by S. Roesler                 *
6202 ************************************************************************
6203
6204       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6205       SAVE
6206
6207       PARAMETER ( LINP = 10 ,
6208      &            LOUT = 6 ,
6209      &            LDAT = 9 )
6210
6211 * Lorentz-parameters of the current interaction
6212       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
6213      &                UMO,PPCM,EPROJ,PPROJ
6214
6215 * sample flavors of sea-quarks
6216       CALL DT_SPLFLA(NN,1)
6217
6218 * sample x-values of partons at chain ends
6219       ECM = UMO
6220       CALL DT_XKSAMP(NN,ECM)
6221
6222 * samle flavors
6223       CALL DT_SPLFLA(NN,2)
6224
6225       RETURN
6226       END
6227
6228 *$ CREATE DT_SPLFLA.FOR
6229 *COPY DT_SPLFLA
6230 *
6231 *===splfla=============================================================*
6232 *
6233       SUBROUTINE DT_SPLFLA(NN,MODE)
6234
6235 ************************************************************************
6236 * SamPLing of FLAvors of partons at chain ends.                        *
6237 * This subroutine replaces FLKSAA/FLKSAM.                              *
6238 *            NN            number of nucleon-nucleon interactions      *
6239 *            MODE = 1      sea-flavors                                 *
6240 *                 = 2      valence-flavors                             *
6241 * Based on the original version written by J. Ranft/H.-J. Moehring.    *
6242 * This version dated 16.01.95 is written by S. Roesler                 *
6243 ************************************************************************
6244
6245       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6246       SAVE
6247
6248       PARAMETER ( LINP = 10 ,
6249      &            LOUT = 6 ,
6250      &            LDAT = 9 )
6251
6252       PARAMETER ( MAXNCL = 260,
6253
6254      &            MAXVQU = MAXNCL,
6255      &            MAXSQU = 20*MAXVQU,
6256      &            MAXINT = MAXVQU+MAXSQU)
6257
6258 * flavors of partons (DTUNUC 1.x)
6259       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6260      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6261      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
6262      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6263      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
6264      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6265      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
6266
6267 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6268       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6269      &                IXPV,IXPS,IXTV,IXTS,
6270      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
6271      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
6272      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
6273      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
6274      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
6275      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
6276      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
6277      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
6278
6279 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6280       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6281      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6282
6283 * particle properties (BAMJET index convention)
6284       CHARACTER*8  ANAME
6285       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6286      &                IICH(210),IIBAR(210),K1(210),K2(210)
6287
6288 * various options for treatment of partons (DTUNUC 1.x)
6289 * (chain recombination, Cronin,..)
6290       LOGICAL LCO2CR,LINTPT
6291       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6292      &                LCO2CR,LINTPT
6293
6294       IF (MODE.EQ.1) THEN
6295 * sea-flavors
6296          DO 1 I=1,NN
6297             IPSQ(I)  = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6298             IPSAQ(I) = -IPSQ(I)
6299     1    CONTINUE
6300          DO 2 I=1,NN
6301             ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6302             ITSAQ(I)= -ITSQ(I)
6303     2    CONTINUE
6304       ELSEIF (MODE.EQ.2) THEN
6305 * valence flavors
6306          DO 3 I=1,IXPV
6307             CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
6308     3    CONTINUE
6309          DO 4 I=1,IXTV
6310             CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
6311     4    CONTINUE
6312       ENDIF
6313
6314       RETURN
6315       END
6316
6317 *$ CREATE DT_GETPTN.FOR
6318 *COPY DT_GETPTN
6319 *
6320 *===getptn=============================================================*
6321 *
6322       SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
6323
6324 ************************************************************************
6325 * This subroutine collects partons at chain ends from temporary        *
6326 * commons and puts them into DTEVT1.                                   *
6327 * This version dated 15.01.95 is written by S. Roesler                 *
6328 ************************************************************************
6329
6330       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6331       SAVE
6332
6333       PARAMETER ( LINP = 10 ,
6334      &            LOUT = 6 ,
6335      &            LDAT = 9 )
6336
6337       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
6338
6339       LOGICAL LCHK
6340
6341       PARAMETER ( MAXNCL = 260,
6342
6343      &            MAXVQU = MAXNCL,
6344      &            MAXSQU = 20*MAXVQU,
6345      &            MAXINT = MAXVQU+MAXSQU)
6346
6347 * event history
6348
6349       PARAMETER (NMXHKK=200000)
6350
6351       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6352      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6353      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6354
6355 * extended event history
6356       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6357      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6358      &                IHIST(2,NMXHKK)
6359
6360 * flags for input different options
6361       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6362       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6363      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6364
6365 * auxiliary common for chain system storage (DTUNUC 1.x)
6366       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
6367
6368 * statistics
6369       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6370      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6371      &                ICEVTG(8,0:30)
6372
6373 * flags for diffractive interactions (DTUNUC 1.x)
6374       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6375
6376 * x-values of partons (DTUNUC 1.x)
6377       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
6378      &                XTVQ(MAXVQU),XTVD(MAXVQU),
6379      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
6380      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
6381
6382 * flavors of partons (DTUNUC 1.x)
6383       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6384      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6385      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
6386      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6387      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
6388      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6389      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
6390
6391 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6392       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6393      &                IXPV,IXPS,IXTV,IXTS,
6394      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
6395      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
6396      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
6397      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
6398      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
6399      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
6400      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
6401      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
6402
6403 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6404       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6405      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6406
6407       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6408
6409       DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6410
6411       IREJ      = 0
6412       NCSY      = 0
6413       NPOINT(2) = NHKK+1
6414
6415 * sea-sea chains
6416       DO 10 I=1,NSS
6417          IF (ISKPCH(1,I).EQ.99) GOTO 10
6418          ICCHAI(1,1) = ICCHAI(1,1)+2
6419          IDXP = INTSS1(I)
6420          IDXT = INTSS2(I)
6421          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6422          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6423          DO 11 K=1,4
6424             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6425             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6426             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6427             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6428    11    CONTINUE
6429          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6430      &                                  +(PP1(3)+PT1(3))**2)
6431          ECH   = PP1(4)+PT1(4)
6432          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6433          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6434      &                                  +(PP2(3)+PT2(3))**2)
6435          ECH   = PP2(4)+PT2(4)
6436          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6437          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6438             AM1 = SQRT(AM1)
6439             AM2 = SQRT(AM2)
6440             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6441 C              WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6442  5000          FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6443             ENDIF
6444          ELSE
6445             WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6446          ENDIF
6447          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6448          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6449          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6450          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6451          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6452      &                                                    0,0,1)
6453          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6454      &                                                    0,0,1)
6455          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6456      &                                                    0,0,1)
6457          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6458      &                                                    0,0,1)
6459          NCSY = NCSY+1
6460    10 CONTINUE
6461
6462 * disea-sea chains
6463       DO 20 I=1,NDS
6464          IF (ISKPCH(2,I).EQ.99) GOTO 20
6465          ICCHAI(1,2) = ICCHAI(1,2)+2
6466          IDXP = INTDS1(I)
6467          IDXT = INTDS2(I)
6468          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6469          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6470          DO 21 K=1,4
6471             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6472             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6473             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6474             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6475    21    CONTINUE
6476          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6477      &                                  +(PP1(3)+PT1(3))**2)
6478          ECH   = PP1(4)+PT1(4)
6479          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6480          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6481      &                                  +(PP2(3)+PT2(3))**2)
6482          ECH   = PP2(4)+PT2(4)
6483          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6484          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6485             AM1 = SQRT(AM1)
6486             AM2 = SQRT(AM2)
6487             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6488 C              WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6489  5001          FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6490             ENDIF
6491          ELSE
6492             WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6493          ENDIF
6494          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6495          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6496          IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6497          IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6498          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6499      &                                                    0,0,2)
6500          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6501      &                                                    0,0,2)
6502          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6503      &                                                    0,0,2)
6504          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6505      &                                                    0,0,2)
6506          NCSY = NCSY+1
6507    20 CONTINUE
6508
6509 * sea-disea chains
6510       DO 30 I=1,NSD
6511          IF (ISKPCH(3,I).EQ.99) GOTO 30
6512          ICCHAI(1,3) = ICCHAI(1,3)+2
6513          IDXP = INTSD1(I)
6514          IDXT = INTSD2(I)
6515          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6516          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6517          DO 31 K=1,4
6518             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6519             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6520             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6521             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6522    31    CONTINUE
6523          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6524      &                                  +(PP1(3)+PT1(3))**2)
6525          ECH   = PP1(4)+PT1(4)
6526          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6527          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6528      &                                  +(PP2(3)+PT2(3))**2)
6529          ECH   = PP2(4)+PT2(4)
6530          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6531          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6532             AM1 = SQRT(AM1)
6533             AM2 = SQRT(AM2)
6534             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6535 C              WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6536  5002          FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6537             ENDIF
6538          ELSE
6539             WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6540          ENDIF
6541          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6542          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6543          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6544          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6545          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6546      &                                                    0,0,3)
6547          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6548      &                                                    0,0,3)
6549          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6550      &                                                    0,0,3)
6551          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6552      &                                                    0,0,3)
6553          NCSY = NCSY+1
6554    30 CONTINUE
6555
6556 * disea-valence chains
6557       DO 50 I=1,NDV
6558          IF (ISKPCH(5,I).EQ.99) GOTO 50
6559          ICCHAI(1,5) = ICCHAI(1,5)+2
6560          IDXP = INTDV1(I)
6561          IDXT = INTDV2(I)
6562          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6563          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6564          DO 51 K=1,4
6565             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6566             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6567             PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6568             PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6569    51    CONTINUE
6570          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6571      &                                  +(PP1(3)+PT1(3))**2)
6572          ECH   = PP1(4)+PT1(4)
6573          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6574          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6575      &                                  +(PP2(3)+PT2(3))**2)
6576          ECH   = PP2(4)+PT2(4)
6577          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6578          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6579             AM1 = SQRT(AM1)
6580             AM2 = SQRT(AM2)
6581             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6582 C              WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6583  5003          FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6584             ENDIF
6585          ELSE
6586             WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6587          ENDIF
6588          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6589          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6590          IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6591          IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6592          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6593      &                                                    0,0,5)
6594          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6595      &                                                    0,0,5)
6596          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6597      &                                                    0,0,5)
6598          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6599      &                                                    0,0,5)
6600          NCSY = NCSY+1
6601    50 CONTINUE
6602
6603 * valence-sea chains
6604       DO 60 I=1,NVS
6605          IF (ISKPCH(6,I).EQ.99) GOTO 60
6606          ICCHAI(1,6) = ICCHAI(1,6)+2
6607          IDXP = INTVS1(I)
6608          IDXT = INTVS2(I)
6609          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6610          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6611          DO 61 K=1,4
6612             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6613             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6614             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6615             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6616    61    CONTINUE
6617          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6618          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6619          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6620          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6621          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6622          IF (LCHK) THEN
6623             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6624      &                                                       0,0,6)
6625             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6626      &                                                       0,0,6)
6627             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6628      &                                                       0,0,6)
6629             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6630      &                                                       0,0,6)
6631             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6632      &                                     +(PP1(3)+PT1(3))**2)
6633             ECH   = PP1(4)+PT1(4)
6634             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6635             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6636      &                                     +(PP2(3)+PT2(3))**2)
6637             ECH   = PP2(4)+PT2(4)
6638             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6639          ELSE
6640             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6641      &                                                       0,0,6)
6642             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6643      &                                                       0,0,6)
6644             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6645      &                                                       0,0,6)
6646             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6647      &                                                       0,0,6)
6648             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6649      &                                     +(PP1(3)+PT2(3))**2)
6650             ECH   = PP1(4)+PT2(4)
6651             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6652             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6653      &                                     +(PP2(3)+PT1(3))**2)
6654             ECH   = PP2(4)+PT1(4)
6655             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6656          ENDIF
6657          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6658             AM1 = SQRT(AM1)
6659             AM2 = SQRT(AM2)
6660             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6661 C              WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6662  5004          FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6663             ENDIF
6664          ELSE
6665             WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6666          ENDIF
6667          NCSY = NCSY+1
6668    60 CONTINUE
6669
6670 * sea-valence chains
6671       DO 40 I=1,NSV
6672          IF (ISKPCH(4,I).EQ.99) GOTO 40
6673          ICCHAI(1,4) = ICCHAI(1,4)+2
6674          IDXP = INTSV1(I)
6675          IDXT = INTSV2(I)
6676          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6677          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6678          DO 41 K=1,4
6679             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6680             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6681             PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6682             PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6683    41    CONTINUE
6684          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6685      &                                  +(PP1(3)+PT1(3))**2)
6686          ECH   = PP1(4)+PT1(4)
6687          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6688          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6689      &                                  +(PP2(3)+PT2(3))**2)
6690          ECH   = PP2(4)+PT2(4)
6691          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6692          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6693             AM1 = SQRT(AM1)
6694             AM2 = SQRT(AM2)
6695             IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6696 C              WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6697  5005          FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6698             ENDIF
6699          ELSE
6700             WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6701          ENDIF
6702          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6703          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6704          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6705          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6706          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6707      &                                                    0,0,4)
6708          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6709      &                                                    0,0,4)
6710          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6711      &                                                    0,0,4)
6712          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6713      &                                                    0,0,4)
6714          NCSY = NCSY+1
6715    40 CONTINUE
6716
6717 * valence-disea chains
6718       DO 70 I=1,NVD
6719          IF (ISKPCH(7,I).EQ.99) GOTO 70
6720          ICCHAI(1,7) = ICCHAI(1,7)+2
6721          IDXP = INTVD1(I)
6722          IDXT = INTVD2(I)
6723          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6724          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6725          DO 71 K=1,4
6726             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6727             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6728             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6729             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6730    71    CONTINUE
6731          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6732          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6733          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6734          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6735          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6736          IF (LCHK) THEN
6737             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6738      &                                                       0,0,7)
6739             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6740      &                                                       0,0,7)
6741             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6742      &                                                       0,0,7)
6743             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6744      &                                                       0,0,7)
6745             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6746      &                                     +(PP1(3)+PT1(3))**2)
6747             ECH   = PP1(4)+PT1(4)
6748             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6749             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6750      &                                     +(PP2(3)+PT2(3))**2)
6751             ECH   = PP2(4)+PT2(4)
6752             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6753          ELSE
6754             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6755      &                                                       0,0,7)
6756             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6757      &                                                       0,0,7)
6758             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6759      &                                                       0,0,7)
6760             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6761      &                                                       0,0,7)
6762             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6763      &                                     +(PP1(3)+PT2(3))**2)
6764             ECH   = PP1(4)+PT2(4)
6765             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6766             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6767      &                                     +(PP2(3)+PT1(3))**2)
6768             ECH   = PP2(4)+PT1(4)
6769             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6770          ENDIF
6771          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6772             AM1 = SQRT(AM1)
6773             AM2 = SQRT(AM2)
6774             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6775 C              WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6776  5006          FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6777             ENDIF
6778          ELSE
6779             WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6780          ENDIF
6781          NCSY = NCSY+1
6782    70 CONTINUE
6783
6784 * valence-valence chains
6785       DO 80 I=1,NVV
6786          IF (ISKPCH(8,I).EQ.99) GOTO 80
6787          ICCHAI(1,8) = ICCHAI(1,8)+2
6788          IDXP = INTVV1(I)
6789          IDXT = INTVV2(I)
6790          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6791          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6792          DO 81 K=1,4
6793             PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6794             PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6795             PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6796             PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6797    81    CONTINUE
6798          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6799          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6800          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6801          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6802
6803 * check for diffractive event
6804          IDIFF = 0
6805          IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6806      &        (IP.EQ.1).AND.(NN.EQ.1)) THEN
6807             DO 800 K=1,4
6808                PP(K) = PP1(K)+PP2(K)
6809                PT(K) = PT1(K)+PT2(K)
6810   800       CONTINUE
6811             ISTCK = NHKK
6812             CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6813      &                  IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6814 C           IF (IREJ1.NE.0) GOTO 9999
6815             IF (IREJ1.NE.0) THEN
6816                IDIFF = 0
6817                NHKK  = ISTCK
6818             ENDIF
6819          ELSE
6820             IDIFF = 0
6821          ENDIF
6822
6823          IF (IDIFF.EQ.0) THEN
6824 *   valence-valence chain system
6825             CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6826             IF (LCHK) THEN
6827 *    baryon-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,IFT1,MOT,0,
6831      &                     PT1(1),PT1(2),PT1(3),PT1(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,IFT2,MOT,0,
6835      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6836                PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6837      &                                        +(PP1(3)+PT1(3))**2)
6838                ECH   = PP1(4)+PT1(4)
6839                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6840                PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6841      &                                        +(PP2(3)+PT2(3))**2)
6842                ECH   = PP2(4)+PT2(4)
6843                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6844             ELSE
6845 *    antibaryon-baryon
6846                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6847      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6848                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6849      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6850                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6851      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6852                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6853      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6854                PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6855      &                                        +(PP1(3)+PT2(3))**2)
6856                ECH   = PP1(4)+PT2(4)
6857                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6858                PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6859      &                                        +(PP2(3)+PT1(3))**2)
6860                ECH   = PP2(4)+PT1(4)
6861                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6862             ENDIF
6863             IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6864                AM1 = SQRT(AM1)
6865                AM2 = SQRT(AM2)
6866                IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6867 C                 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6868  5007             FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6869                ENDIF
6870             ELSE
6871                WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6872             ENDIF
6873             NCSY = NCSY+1
6874          ENDIF
6875    80 CONTINUE
6876       IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6877
6878 * energy-momentum & flavor conservation check
6879       IF (ABS(IDIFF).NE.1) THEN
6880          IF (IDIFF.NE.0) THEN
6881             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6882      &                                              1,3,10,IREJ)
6883          ELSE
6884             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6885      &                                              1,3,10,IREJ)
6886          ENDIF
6887          IF (IREJ.NE.0) THEN
6888             CALL DT_EVTOUT(4)
6889             STOP
6890          ENDIF
6891       ENDIF
6892
6893       RETURN
6894
6895  9999 CONTINUE
6896       IREJ  = 1
6897       RETURN
6898       END
6899
6900 *$ CREATE DT_CHKCSY.FOR
6901 *COPY DT_CHKCSY
6902 *
6903 *===chkcsy=============================================================*
6904 *
6905       SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6906
6907 ************************************************************************
6908 * CHeCk Chain SYstem for consistency of partons at chain ends.         *
6909 *            ID1,ID2        PDG-numbers of partons at chain ends       *
6910 *            LCHK = .true.  consistent chain                           *
6911 *                 = .false. inconsistent chain                         *
6912 * This version dated 18.01.95 is written by S. Roesler                 *
6913 ************************************************************************
6914
6915       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6916       SAVE
6917
6918       PARAMETER ( LINP = 10 ,
6919      &            LOUT = 6 ,
6920      &            LDAT = 9 )
6921
6922       LOGICAL LCHK
6923
6924       LCHK = .TRUE.
6925
6926 * q-aq chain
6927       IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6928          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6929 * q-qq, aq-aqaq chain
6930       ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6931      &        ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6932          IF (ID1*ID2.LT.0) LCHK = .FALSE.
6933 * qq-aqaq chain
6934       ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6935          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6936       ENDIF
6937
6938       RETURN
6939       END
6940
6941 *$ CREATE DT_EVENTA.FOR
6942 *COPY DT_EVENTA
6943 *
6944 *===eventa=============================================================*
6945 *
6946       SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6947
6948 ************************************************************************
6949 * Treatment of nucleon-nucleon interactions in a two-chain             *
6950 * approximation.                                                       *
6951 *  (input) ID       BAMJET-index of projectile hadron (in case of      *
6952 *                   h-K scattering)                                    *
6953 *          IP/IT    mass number of projectile/target nucleus           *
6954 *          NCSY     number of two chain systems                        *
6955 *          IREJ     rejection flag                                     *
6956 * This version dated 15.01.95 is written by S. Roesler                 *
6957 ************************************************************************
6958
6959       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6960       SAVE
6961
6962       PARAMETER ( LINP = 10 ,
6963      &            LOUT = 6 ,
6964      &            LDAT = 9 )
6965
6966       PARAMETER (TINY10=1.0D-10)
6967
6968 * event history
6969
6970       PARAMETER (NMXHKK=200000)
6971
6972       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6973      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6974      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6975
6976 * extended event history
6977       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6978      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6979      &                IHIST(2,NMXHKK)
6980
6981 * rejection counter
6982       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6983      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6984      &                IREXCI(3),IRDIFF(2),IRINC
6985
6986 * flags for diffractive interactions (DTUNUC 1.x)
6987       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6988
6989 * particle properties (BAMJET index convention)
6990       CHARACTER*8  ANAME
6991       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6992      &                IICH(210),IIBAR(210),K1(210),K2(210)
6993
6994 * flags for input different options
6995       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6996       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6997      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6998
6999 * various options for treatment of partons (DTUNUC 1.x)
7000 * (chain recombination, Cronin,..)
7001       LOGICAL LCO2CR,LINTPT
7002       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
7003      &                LCO2CR,LINTPT
7004
7005       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
7006
7007       IREJ      = 0
7008       NPOINT(3) = NHKK+1
7009
7010 * skip following treatment for low-mass diffraction
7011       IF (ABS(IFLAGD).EQ.1) THEN
7012          NPOINT(3) = NPOINT(2)
7013          GOTO 5
7014       ENDIF
7015
7016 * multiple scattering of chain ends
7017       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
7018       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
7019
7020       NC = NPOINT(2)
7021 * get a two-chain system from DTEVT1
7022       DO 3 I=1,NCSY
7023          IFP1 = IDHKK(NC)
7024          IFT1 = IDHKK(NC+1)
7025          IFP2 = IDHKK(NC+2)
7026          IFT2 = IDHKK(NC+3)
7027          DO 4 K=1,4
7028             PP1(K) = PHKK(K,NC)
7029             PT1(K) = PHKK(K,NC+1)
7030             PP2(K) = PHKK(K,NC+2)
7031             PT2(K) = PHKK(K,NC+3)
7032     4    CONTINUE
7033          MOP1 = NC
7034          MOT1 = NC+1
7035          MOP2 = NC+2
7036          MOT2 = NC+3
7037          CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
7038      &               IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
7039          IF (IREJ1.GT.0) THEN
7040             IRHHA = IRHHA+1
7041             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
7042             GOTO 9999
7043          ENDIF
7044          NC = NC+4
7045     3 CONTINUE
7046
7047 * meson/antibaryon projectile:
7048 * sample single-chain valence-valence systems (Reggeon contrib.)
7049       IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
7050          IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
7051       ENDIF
7052
7053       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7054 * check DTEVT1 for remaining resonance mass corrections
7055          CALL DT_EVTRES(IREJ1)
7056          IF (IREJ1.GT.0) THEN
7057             IRRES(1) = IRRES(1)+1
7058             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
7059             GOTO 9999
7060          ENDIF
7061       ENDIF
7062
7063 * assign p_t to two-"chain" systems consisting of two resonances only
7064 * since only entries for chains will be affected, this is obsolete
7065 * in case of JETSET-fragmetation
7066       CALL DT_RESPT
7067
7068 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
7069       IF (LCO2CR) CALL DT_COM2CR
7070
7071     5 CONTINUE
7072
7073 * fragmentation of the complete event
7074 **uncomment for internal phojet-fragmentation
7075 C     CALL DT_EVTFRA(IREJ1)
7076       CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
7077       IF (IREJ1.GT.0) THEN
7078          IRFRAG = IRFRAG+1
7079          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
7080          GOTO 9999
7081       ENDIF
7082
7083 * decay of possible resonances (should be obsolete)
7084       CALL DT_DECAY1
7085
7086       RETURN
7087
7088  9999 CONTINUE
7089       IREVT = IREVT+1
7090       IREJ  = 1
7091       RETURN
7092       END
7093
7094 *$ CREATE DT_GETCSY.FOR
7095 *COPY DT_GETCSY
7096 *
7097 *===getcsy=============================================================*
7098 *
7099       SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
7100      &                  IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
7101
7102 ************************************************************************
7103 * This version dated 15.01.95 is written by S. Roesler                 *
7104 ************************************************************************
7105
7106       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7107       SAVE
7108
7109       PARAMETER ( LINP = 10 ,
7110      &            LOUT = 6 ,
7111      &            LDAT = 9 )
7112
7113       PARAMETER (TINY10=1.0D-10)
7114
7115 * event history
7116
7117       PARAMETER (NMXHKK=200000)
7118
7119       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7120      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7121      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7122
7123 * extended event history
7124       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7125      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7126      &                IHIST(2,NMXHKK)
7127
7128 * rejection counter
7129       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7130      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7131      &                IREXCI(3),IRDIFF(2),IRINC
7132
7133 * flags for input different options
7134       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7135       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7136      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7137
7138 * flags for diffractive interactions (DTUNUC 1.x)
7139       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
7140
7141       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
7142      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
7143
7144       IREJ  = 0
7145
7146 * get quark content of partons
7147       DO 1 I=1,2
7148          IFP1(I) = 0
7149          IFP2(I) = 0
7150          IFT1(I) = 0
7151          IFT2(I) = 0
7152     1 CONTINUE
7153       IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
7154       IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
7155       IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
7156       IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
7157       IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
7158       IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
7159       IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
7160       IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
7161
7162 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
7163       IDCH1 = 2
7164       IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
7165       IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
7166       IDCH2 = 2
7167       IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
7168       IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
7169
7170 * store initial configuration for energy-momentum cons. check
7171       IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
7172
7173 * sample intrinsic p_t at chain-ends
7174       CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
7175      &            PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
7176      &            AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
7177       IF (IREJ1.NE.0) THEN
7178          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
7179          IRPT = IRPT+1
7180          GOTO 9999
7181       ENDIF
7182
7183 C      IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7184 C         IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
7185 C* check second chain for resonance
7186 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7187 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
7188 C            IF (IREJ1.NE.0) GOTO 9999
7189 C            IF (IDR2.NE.0) THEN
7190 C               CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7191 C     &                     AMCH2,AMCH2N,AMCH1,IREJ1)
7192 C               IF (IREJ1.NE.0) GOTO 9999
7193 C            ENDIF
7194 C* check first chain for resonance
7195 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7196 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
7197 C            IF (IREJ1.NE.0) GOTO 9999
7198 C            IF (IDR1.NE.0) IDR1 = 100*IDR1
7199 C         ELSE
7200 C* check first chain for resonance
7201 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7202 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
7203 C            IF (IREJ1.NE.0) GOTO 9999
7204 C            IF (IDR1.NE.0) THEN
7205 C               CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7206 C     &                     AMCH1,AMCH1N,AMCH2,IREJ1)
7207 C               IF (IREJ1.NE.0) GOTO 9999
7208 C            ENDIF
7209 C* check second chain for resonance
7210 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7211 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
7212 C            IF (IREJ1.NE.0) GOTO 9999
7213 C            IF (IDR2.NE.0) IDR2 = 100*IDR2
7214 C         ENDIF
7215 C      ENDIF
7216
7217       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7218 * check chains for resonances
7219          CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7220      &               AMCH1,AMCH1N,IDCH1,IREJ1)
7221          IF (IREJ1.NE.0) GOTO 9999
7222          CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7223      &               AMCH2,AMCH2N,IDCH2,IREJ1)
7224          IF (IREJ1.NE.0) GOTO 9999
7225 * change kinematics corresponding to resonance-masses
7226          IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
7227             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7228      &                                 AMCH1,AMCH1N,AMCH2,IREJ1)
7229             IF (IREJ1.GT.0) GOTO 9999
7230             IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7231             CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7232      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
7233             IF (IREJ1.NE.0) GOTO 9999
7234             IF (IDR2.NE.0) IDR2 = 100*IDR2
7235          ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
7236             CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7237      &                                 AMCH2,AMCH2N,AMCH1,IREJ1)
7238             IF (IREJ1.GT.0) GOTO 9999
7239             IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7240             CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7241      &                  AMCH1,AMCH1N,IDCH1,IREJ1)
7242             IF (IREJ1.NE.0) GOTO 9999
7243             IF (IDR1.NE.0) IDR1 = 100*IDR1
7244          ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
7245             AMDIF1 = ABS(AMCH1-AMCH1N)
7246             AMDIF2 = ABS(AMCH2-AMCH2N)
7247             IF (AMDIF2.LT.AMDIF1) THEN
7248                CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7249      &                                    AMCH2,AMCH2N,AMCH1,IREJ1)
7250                IF (IREJ1.GT.0) GOTO 9999
7251                IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7252                CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
7253      &                     IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
7254                IF (IREJ1.NE.0) GOTO 9999
7255                IF (IDR1.NE.0) IDR1 = 100*IDR1
7256             ELSE
7257                CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7258      &                                    AMCH1,AMCH1N,AMCH2,IREJ1)
7259                IF (IREJ1.GT.0) GOTO 9999
7260                IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7261                CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
7262      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
7263                IF (IREJ1.NE.0) GOTO 9999
7264                IF (IDR2.NE.0) IDR2 = 100*IDR2
7265             ENDIF
7266          ENDIF
7267       ENDIF
7268
7269 * store final configuration for energy-momentum cons. check
7270       IF (LEMCCK) THEN
7271          CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
7272          CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
7273          IF (IREJ1.NE.0) GOTO 9999
7274       ENDIF
7275
7276 * put partons and chains into DTEVT1
7277       DO 10 I=1,4
7278          PCH1(I) = PP1(I)+PT1(I)
7279          PCH2(I) = PP2(I)+PT2(I)
7280    10 CONTINUE
7281       CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
7282      &                                      PP1(3),PP1(4),0,0,0)
7283       CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
7284      &                                      PT1(3),PT1(4),0,0,0)
7285       KCH = 100+IDCH(MOP1)*10+1
7286       CALL DT_EVTPUT(KCH,88888,-2,-1,
7287      &           PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
7288       CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
7289      &                                      PP2(3),PP2(4),0,0,0)
7290       CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
7291      &                                      PT2(3),PT2(4),0,0,0)
7292       KCH = KCH+1
7293       CALL DT_EVTPUT(KCH,88888,-2,-1,
7294      &           PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
7295
7296       RETURN
7297
7298  9999 CONTINUE
7299       IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
7300 * "cancel" sea-sea chains
7301          CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
7302          IF (IREJ1.NE.0) GOTO 9998
7303 **sr 16.5. flag for EVENTB
7304          IREJ = -1
7305          RETURN
7306       ENDIF
7307  9998 CONTINUE
7308       IREJ = 1
7309       RETURN
7310       END
7311
7312 *$ CREATE DT_CHKINE.FOR
7313 *COPY DT_CHKINE
7314 *
7315 *===chkine=============================================================*
7316 *
7317       SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
7318      &                  AMCH1,AMCH1N,AMCH2,IREJ)
7319
7320 ************************************************************************
7321 * This subroutine replaces CORMOM.                                     *
7322 * This version dated 05.01.95 is written by S. Roesler                 *
7323 ************************************************************************
7324
7325       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7326       SAVE
7327
7328       PARAMETER ( LINP = 10 ,
7329      &            LOUT = 6 ,
7330      &            LDAT = 9 )
7331
7332       PARAMETER (TINY10=1.0D-10)
7333
7334 * flags for input different options
7335       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7336       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7337      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7338
7339 * rejection counter
7340       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7341      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7342      &                IREXCI(3),IRDIFF(2),IRINC
7343
7344       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
7345      &          PP1I(4),PP2I(4),PT1I(4),PT2I(4)
7346
7347       IREJ  = 0
7348       JMSHL = IMSHL
7349
7350       SCALE  = AMCH1N/MAX(AMCH1,TINY10)
7351       DO 10 I=1,4
7352          PP1(I) = PP1I(I)
7353          PP2(I) = PP2I(I)
7354          PT1(I) = PT1I(I)
7355          PT2(I) = PT2I(I)
7356          PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
7357          PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
7358          PP1(I) = SCALE*PP1(I)
7359          PT1(I) = SCALE*PT1(I)
7360    10 CONTINUE
7361       IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
7362      &    (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
7363
7364       ECH = PP2(4)+PT2(4)
7365       PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
7366      &                               (PP2(3)+PT2(3))**2 )
7367       AMCH22 = (ECH-PCH)*(ECH+PCH)
7368       IF (AMCH22.LT.0.0D0) THEN
7369          IF (IOULEV(1).GT.0)
7370      &      WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
7371          GOTO 9997
7372       ENDIF
7373
7374       AMCH1 = AMCH1N
7375       AMCH2 = SQRT(AMCH22)
7376
7377 * put partons again on mass shell
7378    13 CONTINUE
7379       XM1 = 0.0D0
7380       XM2 = 0.0D0
7381       IF (JMSHL.EQ.1) THEN
7382
7383          XM1 = PYMASS(IFP1)
7384          XM2 = PYMASS(IFT1)
7385
7386       ENDIF
7387       CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
7388       IF (IREJ1.NE.0) THEN
7389          IF (JMSHL.EQ.0) GOTO 9998
7390          JMSHL = 0
7391          GOTO 13
7392       ENDIF
7393       JMSHL = IMSHL
7394       DO 11 I=1,4
7395          PP1(I) = P1(I)
7396          PT1(I) = P2(I)
7397    11 CONTINUE
7398    14 CONTINUE
7399       XM1 = 0.0D0
7400       XM2 = 0.0D0
7401       IF (JMSHL.EQ.1) THEN
7402
7403          XM1 = PYMASS(IFP2)
7404          XM2 = PYMASS(IFT2)
7405
7406       ENDIF
7407       CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
7408       IF (IREJ1.NE.0) THEN
7409          IF (JMSHL.EQ.0) GOTO 9998
7410          JMSHL = 0
7411          GOTO 14
7412       ENDIF
7413       DO 12 I=1,4
7414          PP2(I) = P1(I)
7415          PT2(I) = P2(I)
7416    12 CONTINUE
7417       DO 15 I=1,4
7418          PP1I(I) = PP1(I)
7419          PP2I(I) = PP2(I)
7420          PT1I(I) = PT1(I)
7421          PT2I(I) = PT2(I)
7422    15 CONTINUE
7423       RETURN
7424
7425  9997 IRCHKI(1) = IRCHKI(1)+1
7426 **sr
7427 C     GOTO 9999
7428       IREJ = -1
7429       RETURN
7430 **
7431  9998 IRCHKI(2) = IRCHKI(2)+1
7432
7433  9999 CONTINUE
7434       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7435       IREJ = 1
7436       RETURN
7437       END
7438
7439 *$ CREATE DT_CH2RES.FOR
7440 *COPY DT_CH2RES
7441 *
7442 *===ch2res=============================================================*
7443 *
7444       SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7445      &                  AM,AMN,IMODE,IREJ)
7446
7447 ************************************************************************
7448 * Check chains for resonance production.                               *
7449 * This subroutine replaces COMCMA/COBCMA/COMCM2                        *
7450 *    input:                                                            *
7451 *          IF1,2,3,4    input flavors (q,aq in any order)              *
7452 *          AM           chain mass                                     *
7453 *          MODE = 1     check q-aq chain for meson-resonance           *
7454 *               = 2     check q-qq, aq-aqaq chain for baryon-resonance *
7455 *               = 3     check qq-aqaq chain for lower mass cut         *
7456 *    output:                                                           *
7457 *          IDR = 0      no resonances found                            *
7458 *              = -1     pseudoscalar meson/octet baryon                *
7459 *              = 1      vector-meson/decuplet baryon                   *
7460 *          IDXR         BAMJET-index of corresponding resonance        *
7461 *          AMN          mass of corresponding resonance                *
7462 *                                                                      *
7463 *          IREJ         rejection flag                                 *
7464 * This version dated 06.01.95 is written by S. Roesler                 *
7465 ************************************************************************
7466
7467       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7468       SAVE
7469
7470       PARAMETER ( LINP = 10 ,
7471      &            LOUT = 6 ,
7472      &            LDAT = 9 )
7473
7474 * particle properties (BAMJET index convention)
7475       CHARACTER*8  ANAME
7476       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7477      &                IICH(210),IIBAR(210),K1(210),K2(210)
7478
7479 * quark-content to particle index conversion (DTUNUC 1.x)
7480       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7481      &                IA08(6,21),IA10(6,21)
7482
7483 * rejection counter
7484       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7485      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7486      &                IREXCI(3),IRDIFF(2),IRINC
7487
7488 * flags for input different options
7489       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7490       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7491      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7492
7493       DIMENSION IF(4),JF(4)
7494
7495 **sr 4.7. test
7496 C     DATA AMLOM,AMLOB /0.08D0,0.2D0/
7497       DATA AMLOM,AMLOB /0.1D0,0.7D0/
7498 **
7499 C     DATA AMLOM,AMLOB /0.001D0,0.001D0/
7500
7501       MODE = ABS(IMODE)
7502
7503       IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7504          WRITE(LOUT,1000) MODE
7505  1000    FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7506      &          1X,'        program stopped')
7507          STOP
7508       ENDIF
7509
7510       AMX  = AM
7511       IREJ = 0
7512       IDR  = 0
7513       IDXR = 0
7514       AMN  = AMX
7515       IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7516       IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7517
7518       IF(1) = IF1
7519       IF(2) = IF2
7520       IF(3) = IF3
7521       IF(4) = IF4
7522       NF = 0
7523       DO 100 I=1,4
7524          IF (IF(I).NE.0) THEN
7525             NF = NF+1
7526             JF(NF) = IF(I)
7527          ENDIF
7528   100 CONTINUE
7529       IF (NF.LE.MODE) THEN
7530          WRITE(LOUT,1001) MODE,IF
7531  1001    FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7532      &   I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7533          GOTO 9999
7534       ENDIF
7535
7536       GOTO (1,2,3) MODE
7537
7538 * check for meson resonance
7539     1 CONTINUE
7540       IFQ  = JF(1)
7541       IFAQ = ABS(JF(2))
7542       IF (JF(2).GT.0) THEN
7543          IFQ  = JF(2)
7544          IFAQ = ABS(JF(1))
7545       ENDIF
7546       IFPS = IMPS(IFAQ,IFQ)
7547       IFV  = IMVE(IFAQ,IFQ)
7548       AMPS = AAM(IFPS)
7549       AMV  = AAM(IFV)
7550       AMHI = AMV+0.3D0
7551       IF (AMX.LT.AMV) THEN
7552          IF (AMX.LT.AMPS) THEN
7553             IF (IMODE.GT.0) THEN
7554                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7555             ELSE
7556                IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7557             ENDIF
7558             LOMRES = LOMRES+1
7559          ENDIF
7560 *    replace chain by pseudoscalar meson
7561          IDR  = -1
7562          IDXR = IFPS
7563          AMN  = AMPS
7564       ELSEIF (AMX.LT.AMHI) THEN
7565 *    replace chain by vector-meson
7566          IDR  = 1
7567          IDXR = IFV
7568          AMN  = AMV
7569       ENDIF
7570       RETURN
7571
7572 * check for baryon resonance
7573     2 CONTINUE
7574       CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7575       AM8  = AAM(JB8)
7576       AM10 = AAM(JB10)
7577       AMHI = AM10+0.3D0
7578       IF (AMX.LT.AM10) THEN
7579          IF (AMX.LT.AM8) THEN
7580             IF (IMODE.GT.0) THEN
7581                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7582             ELSE
7583                IF (AMX.LT.0.8D0*AM8) GOTO 9999
7584             ENDIF
7585             LOBRES = LOBRES+1
7586          ENDIF
7587 *    replace chain by oktet baryon
7588          IDR  = -1
7589          IDXR = JB8
7590          AMN  = AM8
7591       ELSEIF (AMX.LT.AMHI) THEN
7592          IDR  = 1
7593          IDXR = JB10
7594          AMN  = AM10
7595       ENDIF
7596       RETURN
7597
7598 * check qq-aqaq for lower mass cut
7599     3 CONTINUE
7600 *   empirical definition of AMHI to allow for (b-antib)-pair prod.
7601       AMHI = 2.5D0
7602       IF (AMX.LT.AMHI) GOTO 9999
7603       RETURN
7604
7605  9999 CONTINUE
7606       IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7607      &    WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7608       IREJ = 1
7609       IRRES(2) = IRRES(2)+1
7610       RETURN
7611       END
7612
7613 *$ CREATE DT_RJSEAC.FOR
7614 *COPY DT_RJSEAC
7615 *
7616 *===rjseac=============================================================*
7617 *
7618       SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7619
7620 ************************************************************************
7621 * ReJection of SEA-sea Chains.                                         *
7622 *         MOP1/2       entries of projectile sea-partons in DTEVT1     *
7623 *         MOT1/2       entries of projectile sea-partons in DTEVT1     *
7624 * This version dated 16.01.95 is written by S. Roesler                 *
7625 ************************************************************************
7626
7627       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7628       SAVE
7629
7630       PARAMETER ( LINP = 10 ,
7631      &            LOUT = 6 ,
7632      &            LDAT = 9 )
7633
7634       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7635
7636 * event history
7637
7638       PARAMETER (NMXHKK=200000)
7639
7640       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7641      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7642      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7643
7644 * extended event history
7645       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7646      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7647      &                IHIST(2,NMXHKK)
7648
7649 * statistics
7650       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7651      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7652      &                ICEVTG(8,0:30)
7653
7654       DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7655
7656       IREJ = 0
7657
7658 * projectile sea q-aq-pair
7659 *    indices of sea-pair
7660       IDXSEA(1,1) = MOP1
7661       IDXSEA(1,2) = MOP2
7662 *    index of mother-nucleon
7663       IDXNUC(1)   = JMOHKK(1,MOP1)
7664 *    status of valence quarks to be corrected
7665       ISTVAL(1)   = -21
7666
7667 * target sea q-aq-pair
7668 *    indices of sea-pair
7669       IDXSEA(2,1) = MOT1
7670       IDXSEA(2,2) = MOT2
7671 *    index of mother-nucleon
7672       IDXNUC(2)   = JMOHKK(1,MOT1)
7673 *    status of valence quarks to be corrected
7674       ISTVAL(2)   = -22
7675
7676       DO 1 N=1,2
7677          IDONE = 0
7678          DO 2 I=NPOINT(2),NHKK
7679             IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7680      &          (JMOHKK(1,I).EQ.IDXNUC(N)))   THEN
7681 * valence parton found
7682 *    inrease 4-momentum by sea 4-momentum
7683                DO 3 K=1,4
7684                   PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7685      &                                  PHKK(K,IDXSEA(N,2))
7686     3          CONTINUE
7687                PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7688      &                              PHKK(2,I)**2-PHKK(3,I)**2))
7689 *    "cancel" sea-pair
7690                DO 4 J=1,2
7691                   ISTHKK(IDXSEA(N,J))   = 100
7692                   IDHKK(IDXSEA(N,J))    = 0
7693                   JMOHKK(1,IDXSEA(N,J)) = 0
7694                   JMOHKK(2,IDXSEA(N,J)) = 0
7695                   JDAHKK(1,IDXSEA(N,J)) = 0
7696                   JDAHKK(2,IDXSEA(N,J)) = 0
7697                   DO 5 K=1,4
7698                      PHKK(K,IDXSEA(N,J)) = ZERO
7699                      VHKK(K,IDXSEA(N,J)) = ZERO
7700                      WHKK(K,IDXSEA(N,J)) = ZERO
7701     5             CONTINUE
7702                   PHKK(5,IDXSEA(N,J)) = ZERO
7703     4          CONTINUE
7704                IDONE = 1
7705             ENDIF
7706     2    CONTINUE
7707          IF (IDONE.NE.1) THEN
7708             WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7709  1000       FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7710      &                '-record!',/,1X,'        sea-quark pairs   ',
7711      &                2I5,4X,2I5,'   could not be canceled!')
7712             GOTO 9999
7713          ENDIF
7714     1 CONTINUE
7715       ICRJSS = ICRJSS+1
7716       RETURN
7717
7718  9999 CONTINUE
7719       IREJ = 1
7720       RETURN
7721       END
7722
7723 *$ CREATE DT_VV2SCH.FOR
7724 *COPY DT_VV2SCH
7725 *
7726 *===vv2sch=============================================================*
7727 *
7728       SUBROUTINE DT_VV2SCH
7729
7730 ************************************************************************
7731 * Change Valence-Valence chain systems to Single CHain systems for     *
7732 * hadron-nucleus collisions with meson or antibaryon projectile.       *
7733 * (Reggeon contribution)                                               *
7734 * The single chain system is approximately treated as one chain and a  *
7735 * meson at rest.                                                       *
7736 * This version dated 18.01.95 is written by S. Roesler                 *
7737 ************************************************************************
7738
7739       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7740       SAVE
7741
7742       PARAMETER ( LINP = 10 ,
7743      &            LOUT = 6 ,
7744      &            LDAT = 9 )
7745
7746       PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7747
7748       LOGICAL LSTART
7749
7750 * event history
7751
7752       PARAMETER (NMXHKK=200000)
7753
7754       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7755      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7756      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7757
7758 * extended event history
7759       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7760      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7761      &                IHIST(2,NMXHKK)
7762
7763 * flags for input different options
7764       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7765       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7766      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7767
7768 * statistics
7769       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7770      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7771      &                ICEVTG(8,0:30)
7772
7773       DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7774      &          PCH2(4)
7775
7776       DATA LSTART /.TRUE./
7777
7778       IFSC  = 0
7779       IF (LSTART) THEN
7780          WRITE(LOUT,1000)
7781  1000    FORMAT(/,1X,'VV2SCH:  Reggeon contribution to valance-',
7782      &          'valence chains treated')
7783          LSTART = .FALSE.
7784       ENDIF
7785
7786       NSTOP = NHKK
7787
7788 * get index of first chain
7789       DO 1 I=NPOINT(3),NHKK
7790          IF (IDHKK(I).EQ.88888) THEN
7791             NC = I
7792             GOTO 2
7793          ENDIF
7794     1 CONTINUE
7795
7796     2 CONTINUE
7797       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7798      &                        .AND.(NC.LT.NSTOP)) THEN
7799 * get valence-valence chains
7800          IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7801 *   get "mother"-hadron indices
7802             MO1   = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7803             MO2   = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7804             KPROJ = IDT_ICIHAD(IDHKK(MO1))
7805             KTARG = IDT_ICIHAD(IDHKK(MO2))
7806 *   Lab momentum of projectile hadron
7807             CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7808             PTOT  = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7809      &                                  PHKK(3,MO1)**2)
7810
7811             SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7812             IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7813                ICVV2S = ICVV2S+1
7814 *   single chain requested
7815 *      get flavors of chain-end partons
7816                MO(1) = JMOHKK(1,NC)
7817                MO(2) = JMOHKK(2,NC)
7818                MO(3) = JMOHKK(1,NC+3)
7819                MO(4) = JMOHKK(2,NC+3)
7820                DO 3 I=1,4
7821                   IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7822                   IF(I,2) = 0
7823                   IF (ABS(IDHKK(MO(I))).GE.1000)
7824      &               IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7825     3          CONTINUE
7826 *      which one is the q-aq chain?
7827 *        N1,N1+1 - DTEVT1-entries for q-aq system
7828 *        N2,N2+1 - DTEVT1-entries for the other chain
7829                IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7830                   K1 = 1
7831                   K2 = 3
7832                   N1 = NC-2
7833                   N2 = NC+1
7834                ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7835                   K1 = 3
7836                   K2 = 1
7837                   N1 = NC+1
7838                   N2 = NC-2
7839                ELSE
7840                   GOTO 10
7841                ENDIF
7842                DO 4 K=1,4
7843                   PP1(K) = PHKK(K,N1)
7844                   PT1(K) = PHKK(K,N1+1)
7845                   PP2(K) = PHKK(K,N2)
7846                   PT2(K) = PHKK(K,N2+1)
7847     4          CONTINUE
7848                AMCH1 = PHKK(5,N1+2)
7849                AMCH2 = PHKK(5,N2+2)
7850 *      get meson-identity corresponding to flavors of q-aq chain
7851                ITMP   = IRESRJ
7852                IRESRJ = 0
7853                CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7854      &                     ZERO,AMCH1N,1,IDUM)
7855                IRESRJ = ITMP
7856 *      change kinematics of chains
7857                CALL DT_CHKINE(PP1,IDHKK(N1),  PP2,IDHKK(N2),
7858      &                     PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7859      &                     AMCH1,AMCH1N,AMCH2,IREJ1)
7860                IF (IREJ1.NE.0) GOTO 10
7861 *      check second chain for resonance
7862                IDCHAI = 2
7863                IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7864                CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7865      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7866                IF (IREJ1.NE.0) GOTO 10
7867                IF (IDR2.NE.0) IDR2 = 100*IDR2
7868 *      add partons and chains to DTEVT1
7869                DO 5 K=1,4
7870                   PCH1(K) = PP1(K)+PT1(K)
7871                   PCH2(K) = PP2(K)+PT2(K)
7872     5          CONTINUE
7873                CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7874      &                                             PP1(3),PP1(4),0,0,0)
7875                CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7876      &                                      PT1(2),PT1(3),PT1(4),0,0,0)
7877                KCH = ISTHKK(N1+2)+100
7878                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7879      &                     PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7880                IDHKK(N1+2) = 22222
7881                CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7882      &                                             PP2(3),PP2(4),0,0,0)
7883                CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7884      &                                      PT2(2),PT2(3),PT2(4),0,0,0)
7885                KCH = ISTHKK(N2+2)+100
7886                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7887      &                     PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7888                IDHKK(N2+2) = 22222
7889             ENDIF
7890          ENDIF
7891       ELSE
7892          GOTO 11
7893       ENDIF
7894    10 CONTINUE
7895       NC = NC+6
7896       GOTO 2
7897
7898    11 CONTINUE
7899
7900       RETURN
7901       END
7902
7903 *$ CREATE DT_PHNSCH.FOR
7904 *COPY DT_PHNSCH
7905 *
7906 *=== phnsch ===========================================================*
7907 *
7908       DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7909
7910 *----------------------------------------------------------------------*
7911 *                                                                      *
7912 *     Probability for Hadron Nucleon Single CHain interactions:        *
7913 *                                                                      *
7914 *     Created on 30 december 1993  by    Alfredo Ferrari & Paola Sala  *
7915 *                                                   Infn - Milan       *
7916 *                                                                      *
7917 *     Last change on 04-jan-94     by    Alfredo Ferrari               *
7918 *                                                                      *
7919 *             modified by J.R.for use in DTUNUC  6.1.94                *
7920 *                                                                      *
7921 *     Input variables:                                                 *
7922 *                      Kp = hadron projectile index (Part numbering    *
7923 *                           scheme)                                    *
7924 *                   Ktarg = target nucleon index (1=proton, 8=neutron) *
7925 *                    Plab = projectile laboratory momentum (GeV/c)     *
7926 *     Output variable:                                                 *
7927 *                  Phnsch = probability per single chain (particle     *
7928 *                           exchange) interactions                     *
7929 *                                                                      *
7930 *----------------------------------------------------------------------*
7931
7932       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7933       SAVE
7934
7935       PARAMETER ( LUNOUT = 6  )
7936       PARAMETER ( LUNERR = 6  )
7937       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
7938       PARAMETER ( ZERZER = 0.D+00 )
7939       PARAMETER ( ONEONE = 1.D+00 )
7940       PARAMETER ( TWOTWO = 2.D+00 )
7941       PARAMETER ( FIVFIV = 5.D+00 )
7942       PARAMETER ( HLFHLF = 0.5D+00 )
7943
7944       PARAMETER ( NALLWP = 39   )
7945       PARAMETER ( IDMAXP = 210  )
7946
7947       DIMENSION ICHRGE(39),AM(39)
7948
7949 * particle properties (BAMJET index convention)
7950       CHARACTER*8  ANAME
7951       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7952      &                IICH(210),IIBAR(210),K1(210),K2(210)
7953
7954       DIMENSION KPTOIP(210)
7955
7956 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7957       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7958      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7959      &                IQTCHR(-6:6),MQUARK(3,39)
7960
7961       DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7962       DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7963       EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7964       EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7965       EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7966
7967 * Conversion from part to paprop numbering
7968       DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7969      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7970      & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7971
7972 *  1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7973       DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7974      &    2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7975 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7976       DATA  SGTCO1  /
7977 * 1st reaction: gamma p total
7978      &0.147 D+00, ZERZER  , ZERZER   , 0.0022D+00, -0.0170D+00,
7979 * 2nd reaction: gamma d total
7980      &0.300 D+00, ZERZER  , ZERZER   , 0.0095D+00, -0.057 D+00,
7981 * 3rd reaction: pi+ p total
7982      &16.4  D+00, 19.3D+00, -0.42D+00, 0.19  D+00, ZERZER     ,
7983 * 4th reaction: pi- p total
7984      &33.0  D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03  D+00,
7985 * 5th reaction: pi+/- d total
7986      &56.8  D+00, 42.2D+00, -1.45D+00, 0.65  D+00, -5.39  D+00,
7987 * 6th reaction: K+ p total
7988      &18.1  D+00, ZERZER  , ZERZER   , 0.26  D+00, -1.0   D+00,
7989 * 7th reaction: K+ n total
7990      &18.7  D+00, ZERZER  , ZERZER   , 0.21  D+00, -0.89  D+00,
7991 * 8th reaction: K+ d total
7992      &34.2  D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99  D+00,
7993 * 9th reaction: K- p total
7994      &32.1  D+00, ZERZER  , ZERZER   , 0.66  D+00, -5.6   D+00,
7995 * 10th reaction: K- n total
7996      &25.2  D+00, ZERZER  , ZERZER   , 0.38  D+00, -2.9   D+00/
7997 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7998       DATA  SGTCO2  /
7999 * 11th reaction: K- d total
8000      &57.6  D+00, ZERZER  , ZERZER   , 1.17  D+00, -9.5   D+00,
8001 * 12th reaction: p p total
8002      &48.0  D+00, ZERZER  , ZERZER   , 0.522 D+00, -4.51  D+00,
8003 * 13th reaction: p n total
8004      &47.30 D+00, ZERZER  , ZERZER   , 0.513 D+00, -4.27  D+00,
8005 * 14th reaction: p d total
8006      &91.3  D+00, ZERZER  , ZERZER   , 1.05  D+00, -8.8   D+00,
8007 * 15th reaction: pbar p total
8008      &38.4  D+00, 77.6D+00, -0.64D+00, 0.26  D+00, -1.2   D+00,
8009 * 16th reaction: pbar n total
8010      &ZERZER    ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7   D+00,
8011 * 17th reaction: pbar d total
8012      &112.  D+00, 125.D+00, -1.08D+00, 1.14  D+00, -12.4  D+00,
8013 * 18th reaction: Lamda p total
8014      &30.4  D+00, ZERZER  , ZERZER   , ZERZER    , 1.6    D+00/
8015 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
8016       DATA SGTCO3  /
8017 * 19th reaction: pi+ p elastic
8018      &ZERZER    , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER     ,
8019 * 20th reaction: pi- p elastic
8020      &1.76  D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER     ,
8021 * 21st reaction: K+ p elastic
8022      &5.0   D+00, 8.1 D+00, -1.8 D+00, 0.16  D+00, -1.3   D+00,
8023 * 22nd reaction: K- p elastic
8024      &7.3   D+00, ZERZER  , ZERZER   , 0.29  D+00, -2.40  D+00,
8025 * 23rd reaction: p p elastic
8026      &11.9  D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85  D+00,
8027 * 24th reaction: p d elastic
8028      &16.1  D+00, ZERZER  , ZERZER   , 0.32  D+00, -3.4   D+00,
8029 * 25th reaction: pbar p elastic
8030      &10.2  D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28  D+00,
8031 * 26th reaction: pbar p elastic bis
8032      &10.6  D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41  D+00,
8033 * 27th reaction: pbar n elastic
8034      &36.5  D+00, ZERZER  , ZERZER   , ZERZER    , -11.9  D+00,
8035 * 28th reaction: Lamda p elastic
8036      &12.3  D+00, ZERZER  , ZERZER   , ZERZER    , -2.4   D+00,
8037 * 29th reaction: K- p ela bis
8038      &7.24  D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35  D+00,
8039 * 30th reaction: pi- p cx
8040      &ZERZER    ,0.912D+00, -1.22D+00, ZERZER    , ZERZER     ,
8041 * 31st reaction: K- p cx
8042      &ZERZER    , 3.39D+00, -1.75D+00, ZERZER    , ZERZER     ,
8043 * 32nd reaction: K+ n cx
8044      &ZERZER    , 7.18D+00, -2.01D+00, ZERZER    , ZERZER     ,
8045 * 33rd reaction: pbar p cx
8046      &ZERZER    , 18.8D+00, -2.01D+00, ZERZER    , ZERZER     /
8047 *
8048 *  +-------------------------------------------------------------------*
8049          ICHRGE(KTARG)=IICH(KTARG)
8050          AM    (KTARG)=AAM (KTARG)
8051 *  |  Check for pi0 (d-dbar)
8052       IF ( KP .NE. 26 ) THEN
8053          IP  = KPTOIP (KP)
8054          IF(IP.EQ.0)IP=1
8055          ICHRGE(IP)=IICH(KP)
8056          AM    (IP)=AAM (KP)
8057 *  |
8058 *  +-------------------------------------------------------------------*
8059 *  |
8060       ELSE
8061          IP = 23
8062          ICHRGE(IP)=0
8063       END IF
8064 *  |
8065 *  +-------------------------------------------------------------------*
8066 *  +-------------------------------------------------------------------*
8067 *  |  No such interactions for baryon-baryon
8068       IF ( IIBAR (KP) .GT. 0 ) THEN
8069          DT_PHNSCH = ZERZER
8070          RETURN
8071 *  |
8072 *  +-------------------------------------------------------------------*
8073 *  |  No "annihilation" diagram possible for K+ p/n
8074       ELSE IF ( IP .EQ. 15 ) THEN
8075          DT_PHNSCH = ZERZER
8076          RETURN
8077 *  |
8078 *  +-------------------------------------------------------------------*
8079 *  |  No "annihilation" diagram possible for K0 p/n
8080       ELSE IF ( IP .EQ. 24 ) THEN
8081          DT_PHNSCH = ZERZER
8082          RETURN
8083 *  |
8084 *  +-------------------------------------------------------------------*
8085 *  |  No "annihilation" diagram possible for Omebar p/n
8086       ELSE IF ( IP .GE. 38 ) THEN
8087          DT_PHNSCH = ZERZER
8088          RETURN
8089       END IF
8090 *  |
8091 *  +-------------------------------------------------------------------*
8092 *  +-------------------------------------------------------------------*
8093 *  |  If the momentum is larger than 50 GeV/c, compute the single
8094 *  |  chain probability at 50 GeV/c and extrapolate to the present
8095 *  |  momentum according to 1/sqrt(s)
8096 *  |  sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
8097 *  |  P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
8098 *  |  sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
8099 *  |  sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
8100 *  |                        x sqrt(s/s(50))
8101 *  |  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8102       IF ( PLAB .GT. 50.D+00 ) THEN
8103          PLA    = 50.D+00
8104          AMPSQ  = AM (IP)**2
8105          AMTSQ  = AM (KTARG)**2
8106          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
8107          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8108          EPROJ  = SQRT ( PLA**2 + AMPSQ )
8109          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8110          UMORAT = SQRT ( UMOSQ / UMO50 )
8111 *  |
8112 *  +-------------------------------------------------------------------*
8113 *  |  P < 3 GeV/c
8114       ELSE IF ( PLAB .LT. 3.D+00 ) THEN
8115          PLA    = 3.D+00
8116          AMPSQ  = AM (IP)**2
8117          AMTSQ  = AM (KTARG)**2
8118          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
8119          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8120          EPROJ  = SQRT ( PLA**2 + AMPSQ )
8121          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8122          UMORAT = SQRT ( UMOSQ / UMO50 )
8123 *  |
8124 *  +-------------------------------------------------------------------*
8125 *  |  P < 50 GeV/c
8126       ELSE
8127          PLA    = PLAB
8128          UMORAT = ONEONE
8129       END IF
8130 *  |
8131 *  +-------------------------------------------------------------------*
8132       ALGPLA = LOG (PLA)
8133 *  +-------------------------------------------------------------------*
8134 *  |  Pions:
8135       IF ( IHLP (IP) .EQ. 2 ) THEN
8136          ACOF = SGTCOE (1,3)
8137          BCOF = SGTCOE (2,3)
8138          ENNE = SGTCOE (3,3)
8139          CCOF = SGTCOE (4,3)
8140          DCOF = SGTCOE (5,3)
8141 *  |  Compute the pi+ p total cross section:
8142          SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8143      &          + DCOF * ALGPLA
8144          ACOF = SGTCOE (1,19)
8145          BCOF = SGTCOE (2,19)
8146          ENNE = SGTCOE (3,19)
8147          CCOF = SGTCOE (4,19)
8148          DCOF = SGTCOE (5,19)
8149 *  |  Compute the pi+ p elastic cross section:
8150          SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8151      &          + DCOF * ALGPLA
8152 *  |  Compute the pi+ p inelastic cross section:
8153          SPPPIN = SPPPTT - SPPPEL
8154          ACOF = SGTCOE (1,4)
8155          BCOF = SGTCOE (2,4)
8156          ENNE = SGTCOE (3,4)
8157          CCOF = SGTCOE (4,4)
8158          DCOF = SGTCOE (5,4)
8159 *  |  Compute the pi- p total cross section:
8160          SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8161      &          + DCOF * ALGPLA
8162          ACOF = SGTCOE (1,20)
8163          BCOF = SGTCOE (2,20)
8164          ENNE = SGTCOE (3,20)
8165          CCOF = SGTCOE (4,20)
8166          DCOF = SGTCOE (5,20)
8167 *  |  Compute the pi- p elastic cross section:
8168          SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8169      &          + DCOF * ALGPLA
8170 *  |  Compute the pi- p inelastic cross section:
8171          SPMPIN = SPMPTT - SPMPEL
8172          SIGDIA = SPMPIN - SPPPIN
8173 *  |  +----------------------------------------------------------------*
8174 *  |  |  Charged pions: besides isospin consideration it is supposed
8175 *  |  |                 that (pi+ n)el is almost equal to (pi- p)el
8176 *  |  |                 and  (pi+ p)el "    "     "    "  (pi- n)el
8177 *  |  |                 and all are almost equal among each others
8178 *  |  |                 (reasonable above 5 GeV/c)
8179          IF ( ICHRGE (IP) .NE. 0 ) THEN
8180             KHELP = KTARG / 8
8181             JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
8182             ACOF = SGTCOE (1,JREAC)
8183             BCOF = SGTCOE (2,JREAC)
8184             ENNE = SGTCOE (3,JREAC)
8185             CCOF = SGTCOE (4,JREAC)
8186             DCOF = SGTCOE (5,JREAC)
8187 *  |  |  Compute the total cross section:
8188             SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8189      &             + DCOF * ALGPLA
8190             JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
8191             ACOF = SGTCOE (1,JREAC)
8192             BCOF = SGTCOE (2,JREAC)
8193             ENNE = SGTCOE (3,JREAC)
8194             CCOF = SGTCOE (4,JREAC)
8195             DCOF = SGTCOE (5,JREAC)
8196 *  |  |  Compute the elastic cross section:
8197             SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8198      &             + DCOF * ALGPLA
8199 *  |  |  Compute the inelastic cross section:
8200             SHNCIN = SHNCTT - SHNCEL
8201 *  |  |  Number of diagrams:
8202             NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
8203 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8204             IQFSC1 = 1 + IP - 13
8205             IQFSC2 = 0
8206             IQBSC1 = 1 + KHELP
8207             IQBSC2 = 1 + IP - 13
8208 *  |  |
8209 *  |  +----------------------------------------------------------------*
8210 *  |  |  pi0: besides isospin consideration it is supposed that the
8211 *  |  |       elastic cross section is not very different from
8212 *  |  |       pi+ p and/or pi- p (reasonable above 5 GeV/c)
8213          ELSE
8214             KHELP  = KTARG / 8
8215             K2HLP  = ( KP - 23 ) / 3
8216 *  |  |  Number of diagrams:
8217 *  |  |  For u ubar (k2hlp=0):
8218 *           NDIAGR = 2 - KHELP
8219 *  |  |  For d dbar (k2hlp=1):
8220 *           NDIAGR = 2 + KHELP - K2HLP
8221             NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
8222             SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
8223 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8224             IQFSC1 = 1 + K2HLP
8225             IQFSC2 = 0
8226             IQBSC1 = 1 + KHELP
8227             IQBSC2 = 2 - K2HLP
8228          END IF
8229 *  |  |
8230 *  |  +----------------------------------------------------------------*
8231 *  |                                                   end pi's
8232 *  +-------------------------------------------------------------------*
8233 *  |  Kaons:
8234       ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
8235          ACOF = SGTCOE (1,6)
8236          BCOF = SGTCOE (2,6)
8237          ENNE = SGTCOE (3,6)
8238          CCOF = SGTCOE (4,6)
8239          DCOF = SGTCOE (5,6)
8240 *  |  Compute the K+ p total cross section:
8241          SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8242      &          + DCOF * ALGPLA
8243          ACOF = SGTCOE (1,21)
8244          BCOF = SGTCOE (2,21)
8245          ENNE = SGTCOE (3,21)
8246          CCOF = SGTCOE (4,21)
8247          DCOF = SGTCOE (5,21)
8248 *  |  Compute the K+ p elastic cross section:
8249          SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8250      &          + DCOF * ALGPLA
8251 *  |  Compute the K+ p inelastic cross section:
8252          SKPPIN = SKPPTT - SKPPEL
8253          ACOF = SGTCOE (1,9)
8254          BCOF = SGTCOE (2,9)
8255          ENNE = SGTCOE (3,9)
8256          CCOF = SGTCOE (4,9)
8257          DCOF = SGTCOE (5,9)
8258 *  |  Compute the K- p total cross section:
8259          SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8260      &          + DCOF * ALGPLA
8261          ACOF = SGTCOE (1,22)
8262          BCOF = SGTCOE (2,22)
8263          ENNE = SGTCOE (3,22)
8264          CCOF = SGTCOE (4,22)
8265          DCOF = SGTCOE (5,22)
8266 *  |  Compute the K- p elastic cross section:
8267          SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8268      &          + DCOF * ALGPLA
8269 *  |  Compute the K- p inelastic cross section:
8270          SKMPIN = SKMPTT - SKMPEL
8271          SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
8272 *  |  +----------------------------------------------------------------*
8273 *  |  |  Charged Kaons: actually only K-
8274          IF ( ICHRGE (IP) .NE. 0 ) THEN
8275             KHELP = KTARG / 8
8276 *  |  |  +-------------------------------------------------------------*
8277 *  |  |  |  Proton target:
8278             IF ( KHELP .EQ. 0 ) THEN
8279                SHNCIN = SKMPIN
8280 *  |  |  |  Number of diagrams:
8281                NDIAGR = 2
8282 *  |  |  |
8283 *  |  |  +-------------------------------------------------------------*
8284 *  |  |  |  Neutron target: besides isospin consideration it is supposed
8285 *  |  |  |              that (K- n)el is almost equal to (K- p)el
8286 *  |  |  |              (reasonable above 5 GeV/c)
8287             ELSE
8288                ACOF = SGTCOE (1,10)
8289                BCOF = SGTCOE (2,10)
8290                ENNE = SGTCOE (3,10)
8291                CCOF = SGTCOE (4,10)
8292                DCOF = SGTCOE (5,10)
8293 *  |  |  |  Compute the total cross section:
8294                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8295      &                + DCOF * ALGPLA
8296 *  |  |  |  Compute the elastic cross section:
8297                SHNCEL = SKMPEL
8298 *  |  |  |  Compute the inelastic cross section:
8299                SHNCIN = SHNCTT - SHNCEL
8300 *  |  |  |  Number of diagrams:
8301                NDIAGR = 1
8302             END IF
8303 *  |  |  |
8304 *  |  |  +-------------------------------------------------------------*
8305 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8306             IQFSC1 = 3
8307             IQFSC2 = 0
8308             IQBSC1 = 1 + KHELP
8309             IQBSC2 = 2
8310 *  |  |
8311 *  |  +----------------------------------------------------------------*
8312 *  |  |  K0's: (actually only K0bar)
8313          ELSE
8314             KHELP  = KTARG / 8
8315 *  |  |  +-------------------------------------------------------------*
8316 *  |  |  |  Proton target: (K0bar p)in supposed to be given by
8317 *  |  |  |                 (K- p)in - Sig_diagr
8318             IF ( KHELP .EQ. 0 ) THEN
8319                SHNCIN = SKMPIN - SIGDIA
8320 *  |  |  |  Number of diagrams:
8321                NDIAGR = 1
8322 *  |  |  |
8323 *  |  |  +-------------------------------------------------------------*
8324 *  |  |  |  Neutron target: (K0bar n)in supposed to be given by
8325 *  |  |  |                 (K- n)in + Sig_diagr
8326 *  |  |  |              besides isospin consideration it is supposed
8327 *  |  |  |              that (K- n)el is almost equal to (K- p)el
8328 *  |  |  |              (reasonable above 5 GeV/c)
8329             ELSE
8330                ACOF = SGTCOE (1,10)
8331                BCOF = SGTCOE (2,10)
8332                ENNE = SGTCOE (3,10)
8333                CCOF = SGTCOE (4,10)
8334                DCOF = SGTCOE (5,10)
8335 *  |  |  |  Compute the total cross section:
8336                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8337      &                + DCOF * ALGPLA
8338 *  |  |  |  Compute the elastic cross section:
8339                SHNCEL = SKMPEL
8340 *  |  |  |  Compute the inelastic cross section:
8341                SHNCIN = SHNCTT - SHNCEL + SIGDIA
8342 *  |  |  |  Number of diagrams:
8343                NDIAGR = 2
8344             END IF
8345 *  |  |  |
8346 *  |  |  +-------------------------------------------------------------*
8347 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8348             IQFSC1 = 3
8349             IQFSC2 = 0
8350             IQBSC1 = 1
8351             IQBSC2 = 1 + KHELP
8352          END IF
8353 *  |  |
8354 *  |  +----------------------------------------------------------------*
8355 *  |                                                   end Kaon's
8356 *  +-------------------------------------------------------------------*
8357 *  |  Antinucleons:
8358       ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
8359 *  |  For momenta between 3 and 5 GeV/c the use of tabulated data
8360 *  |  should be implemented!
8361          ACOF = SGTCOE (1,15)
8362          BCOF = SGTCOE (2,15)
8363          ENNE = SGTCOE (3,15)
8364          CCOF = SGTCOE (4,15)
8365          DCOF = SGTCOE (5,15)
8366 *  |  Compute the pbar p total cross section:
8367          SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8368      &          + DCOF * ALGPLA
8369          IF ( PLA .LT. FIVFIV ) THEN
8370             JREAC = 26
8371          ELSE
8372             JREAC = 25
8373          END IF
8374          ACOF = SGTCOE (1,JREAC)
8375          BCOF = SGTCOE (2,JREAC)
8376          ENNE = SGTCOE (3,JREAC)
8377          CCOF = SGTCOE (4,JREAC)
8378          DCOF = SGTCOE (5,JREAC)
8379 *  |  Compute the pbar p elastic cross section:
8380          SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8381      &          + DCOF * ALGPLA
8382 *  |  Compute the pbar p inelastic cross section:
8383          SAPPIN = SAPPTT - SAPPEL
8384          ACOF = SGTCOE (1,12)
8385          BCOF = SGTCOE (2,12)
8386          ENNE = SGTCOE (3,12)
8387          CCOF = SGTCOE (4,12)
8388          DCOF = SGTCOE (5,12)
8389 *  |  Compute the p p total cross section:
8390          SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8391      &          + DCOF * ALGPLA
8392          ACOF = SGTCOE (1,23)
8393          BCOF = SGTCOE (2,23)
8394          ENNE = SGTCOE (3,23)
8395          CCOF = SGTCOE (4,23)
8396          DCOF = SGTCOE (5,23)
8397 *  |  Compute the p p elastic cross section:
8398          SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8399      &          + DCOF * ALGPLA
8400 *  |  Compute the K- p inelastic cross section:
8401          SPPINE = SPPTOT - SPPELA
8402          SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
8403          KHELP  = KTARG / 8
8404 *  |  +----------------------------------------------------------------*
8405 *  |  |  Pbar:
8406          IF ( ICHRGE (IP) .NE. 0 ) THEN
8407             NDIAGR = 5 - KHELP
8408 *  |  |  +-------------------------------------------------------------*
8409 *  |  |  |  Proton target:
8410             IF ( KHELP .EQ. 0 ) THEN
8411 *  |  |  |  Number of diagrams:
8412                SHNCIN = SAPPIN
8413                PUUBAR = 0.8D+00
8414 *  |  |  |
8415 *  |  |  +-------------------------------------------------------------*
8416 *  |  |  |  Neutron target: it is supposed that (ap n)el is almost equal
8417 *  |  |  |                  to (ap p)el (reasonable above 5 GeV/c)
8418             ELSE
8419                ACOF = SGTCOE (1,16)
8420                BCOF = SGTCOE (2,16)
8421                ENNE = SGTCOE (3,16)
8422                CCOF = SGTCOE (4,16)
8423                DCOF = SGTCOE (5,16)
8424 *  |  |  |  Compute the total cross section:
8425                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8426      &                + DCOF * ALGPLA
8427 *  |  |  |  Compute the elastic cross section:
8428                SHNCEL = SAPPEL
8429 *  |  |  |  Compute the inelastic cross section:
8430                SHNCIN = SHNCTT - SHNCEL
8431                PUUBAR = HLFHLF
8432             END IF
8433 *  |  |  |
8434 *  |  |  +-------------------------------------------------------------*
8435 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8436 *  |  |  there are different possibilities, make a random choiche:
8437             IQFSC1 = -1
8438             RNCHEN = DT_RNDM(PUUBAR)
8439             IF ( RNCHEN .LT. PUUBAR ) THEN
8440                IQFSC2 = -2
8441             ELSE
8442                IQFSC2 = -1
8443             END IF
8444             IQBSC1 = -IQFSC1 + KHELP
8445             IQBSC2 = -IQFSC2
8446 *  |  |
8447 *  |  +----------------------------------------------------------------*
8448 *  |  |  nbar:
8449          ELSE
8450             NDIAGR = 4 + KHELP
8451 *  |  |  +-------------------------------------------------------------*
8452 *  |  |  |  Proton target: (nbar p)in supposed to be given by
8453 *  |  |  |                 (pbar p)in - Sig_diagr
8454             IF ( KHELP .EQ. 0 ) THEN
8455                SHNCIN = SAPPIN - SIGDIA
8456                PDDBAR = HLFHLF
8457 *  |  |  |
8458 *  |  |  +-------------------------------------------------------------*
8459 *  |  |  |  Neutron target: (nbar n)el is supposed to be equal to
8460 *  |  |  |                  (pbar p)el (reasonable above 5 GeV/c)
8461             ELSE
8462 *  |  |  |  Compute the total cross section:
8463                SHNCTT = SAPPTT
8464 *  |  |  |  Compute the elastic cross section:
8465                SHNCEL = SAPPEL
8466 *  |  |  |  Compute the inelastic cross section:
8467                SHNCIN = SHNCTT - SHNCEL
8468                PDDBAR = 0.8D+00
8469             END IF
8470 *  |  |  |
8471 *  |  |  +-------------------------------------------------------------*
8472 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8473 *  |  |  there are different possibilities, make a random choiche:
8474             IQFSC1 = -2
8475             RNCHEN = DT_RNDM(RNCHEN)
8476             IF ( RNCHEN .LT. PDDBAR ) THEN
8477                IQFSC2 = -1
8478             ELSE
8479                IQFSC2 = -2
8480             END IF
8481             IQBSC1 = -IQFSC1 + KHELP - 1
8482             IQBSC2 = -IQFSC2
8483          END IF
8484 *  |  |
8485 *  |  +----------------------------------------------------------------*
8486 *  |
8487 *  +-------------------------------------------------------------------*
8488 *  |  Others: not yet implemented
8489       ELSE
8490          SIGDIA = ZERZER
8491          SHNCIN = ONEONE
8492          NDIAGR = 0
8493          DT_PHNSCH = ZERZER
8494          RETURN
8495       END IF
8496 *  |                                                   end others
8497 *  +-------------------------------------------------------------------*
8498       DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8499       IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8500      &       + IQECHR (IQBSC2)
8501       IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8502      &       + IQBCHR (IQBSC2)
8503       IQECHC = IQECHC / 3
8504       IQBCHC = IQBCHC / 3
8505       IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8506      &       + IQSCHR (IQBSC2)
8507       IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8508      &       + IQSCHR (MQUARK(3,IP))
8509 *  +-------------------------------------------------------------------*
8510 *  |  Consistency check:
8511       IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8512          WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8513      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8514          WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8515      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8516          DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8517          DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8518       END IF
8519 *  |
8520 *  +-------------------------------------------------------------------*
8521 *  +-------------------------------------------------------------------*
8522 *  |  Consistency check:
8523       IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8524      &     .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8525          WRITE (LUNOUT,*)
8526      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8527      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8528          WRITE (LUNERR,*)
8529      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8530      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8531       END IF
8532 *  |
8533 *  +-------------------------------------------------------------------*
8534 *  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8535       IF ( UMORAT .GT. ONEPLS )
8536      &   DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8537      &                                 - ONEONE ) * UMORAT + ONEONE )
8538       RETURN
8539 *
8540       ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8541       DT_SCHQUA = ONEONE
8542       JQFSC1 = IQFSC1
8543       JQFSC2 = IQFSC2
8544       JQBSC1 = IQBSC1
8545       JQBSC2 = IQBSC2
8546 *=== End of function Phnsch ===========================================*
8547       RETURN
8548       END
8549
8550 *$ CREATE DT_RESPT.FOR
8551 *COPY DT_RESPT
8552 *
8553 *===respt==============================================================*
8554 *
8555       SUBROUTINE DT_RESPT
8556
8557 ************************************************************************
8558 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t.     *
8559 * This version dated 18.01.95 is written by S. Roesler                 *
8560 ************************************************************************
8561
8562       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8563       SAVE
8564
8565       PARAMETER ( LINP = 10 ,
8566      &            LOUT = 6 ,
8567      &            LDAT = 9 )
8568
8569       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8570
8571 * event history
8572
8573       PARAMETER (NMXHKK=200000)
8574
8575       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8576      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8577      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8578
8579 * extended event history
8580       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8581      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8582      &                IHIST(2,NMXHKK)
8583
8584 * get index of first chain
8585       DO 1 I=NPOINT(3),NHKK
8586          IF (IDHKK(I).EQ.88888) THEN
8587             NC = I
8588             GOTO 2
8589          ENDIF
8590     1 CONTINUE
8591
8592     2 CONTINUE
8593       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8594 C        WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8595 * skip VV-,SS- systems
8596          IF ((IDCH(NC  ).NE.1).AND.(IDCH(NC  ).NE.8).AND.
8597      &       (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8598 * check if both "chains" are resonances
8599             IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8600                CALL DT_SAPTRE(NC,NC+3)
8601             ENDIF
8602          ENDIF
8603       ELSE
8604          GOTO 3
8605       ENDIF
8606       NC = NC+6
8607       GOTO 2
8608
8609     3 CONTINUE
8610
8611       RETURN
8612       END
8613
8614 *$ CREATE DT_EVTRES.FOR
8615 *COPY DT_EVTRES
8616 *
8617 *===evtres=============================================================*
8618 *
8619       SUBROUTINE DT_EVTRES(IREJ)
8620
8621 ************************************************************************
8622 * This version dated 14.12.94 is written by S. Roesler                 *
8623 ************************************************************************
8624
8625       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8626       SAVE
8627
8628       PARAMETER ( LINP = 10 ,
8629      &            LOUT = 6 ,
8630      &            LDAT = 9 )
8631
8632       PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8633
8634 * event history
8635
8636       PARAMETER (NMXHKK=200000)
8637
8638       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8639      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8640      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8641
8642 * extended event history
8643       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8644      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8645      &                IHIST(2,NMXHKK)
8646
8647 * flags for input different options
8648       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8649       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8650      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8651
8652 * particle properties (BAMJET index convention)
8653       CHARACTER*8  ANAME
8654       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8655      &                IICH(210),IIBAR(210),K1(210),K2(210)
8656
8657       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8658
8659       IREJ = 0
8660
8661       DO 1 I=NPOINT(3),NHKK
8662          IF (ABS(IDRES(I)).GE.100) THEN
8663             AMMX = 0.0D0
8664             DO 2 J=NPOINT(3),NHKK
8665                IF (IDHKK(J).EQ.88888) THEN
8666                   IF (PHKK(5,J).GT.AMMX) THEN
8667                      AMMX = PHKK(5,J)
8668                      IMMX = J
8669                   ENDIF
8670                ENDIF
8671     2       CONTINUE
8672             IF (IDRES(IMMX).NE.0) THEN
8673                IF (IOULEV(3).GT.0) THEN
8674                   WRITE(LOUT,'(1X,A)')
8675      &               'EVTRES: no chain for correc. found'
8676 C                 GOTO 6
8677                   GOTO 9999
8678                ELSE
8679                   GOTO 9999
8680                ENDIF
8681             ENDIF
8682             IMO11  = JMOHKK(1,I)
8683             IMO12  = JMOHKK(2,I)
8684             IF (PHKK(3,IMO11).LT.0.0D0) THEN
8685                IMO11 = JMOHKK(2,I)
8686                IMO12 = JMOHKK(1,I)
8687             ENDIF
8688             IMO21  = JMOHKK(1,IMMX)
8689             IMO22  = JMOHKK(2,IMMX)
8690             IF (PHKK(3,IMO21).LT.0.0D0) THEN
8691                IMO21 = JMOHKK(2,IMMX)
8692                IMO22 = JMOHKK(1,IMMX)
8693             ENDIF
8694             AMCH1  = PHKK(5,I)
8695             AMCH1N = AAM(IDXRES(I))
8696
8697             IFPR1 = IDHKK(IMO11)
8698             IFPR2 = IDHKK(IMO21)
8699             IFTA1 = IDHKK(IMO12)
8700             IFTA2 = IDHKK(IMO22)
8701             DO 4 J=1,4
8702                PP1(J) = PHKK(J,IMO11)
8703                PP2(J) = PHKK(J,IMO21)
8704                PT1(J) = PHKK(J,IMO12)
8705                PT2(J) = PHKK(J,IMO22)
8706     4       CONTINUE
8707 * store initial configuration for energy-momentum cons. check
8708             IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8709 * correct kinematics of second chain
8710             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8711      &                  AMCH1,AMCH1N,AMCH2,IREJ1)
8712             IF (IREJ1.NE.0) GOTO 9999
8713 * check now this chain for resonance mass
8714             IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8715             IFP(2) = 0
8716             IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8717             IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8718             IFT(2) = 0
8719             IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8720             IDCH2 = 2
8721             IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8722             IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8723             CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8724      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
8725             IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8726                IF (IOULEV(1).GT.0)
8727      &            WRITE(LOUT,*) ' correction for resonance not poss.'
8728 **sr test
8729 C              GOTO 1
8730 C              GOTO 9999
8731 **
8732             ENDIF
8733 * store final configuration for energy-momentum cons. check
8734             IF (LEMCCK) THEN
8735                CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8736                CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8737                IF (IREJ1.NE.0) GOTO 9999
8738             ENDIF
8739             DO 5 J=1,4
8740                PHKK(J,IMO11) = PP1(J)
8741                PHKK(J,IMO21) = PP2(J)
8742                PHKK(J,IMO12) = PT1(J)
8743                PHKK(J,IMO22) = PT2(J)
8744     5       CONTINUE
8745 * correct entries of chains
8746             DO 3 K=1,4
8747                PHKK(K,I)    = PHKK(K,IMO11)+PHKK(K,IMO12)
8748                PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8749     3       CONTINUE
8750             AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8751             AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8752      &            PHKK(3,IMMX)**2
8753 * ?? the following should now be obsolete
8754 **sr test
8755 C           IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8756             IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8757 **
8758                WRITE(LOUT,'(1X,A,4G10.3)')
8759      &          'EVTRES: inonsistent mass-corr.',AM1,AM2
8760 C              GOTO 9999
8761                GOTO 1
8762             ENDIF
8763             PHKK(5,I)    = SQRT(AM1)
8764             PHKK(5,IMMX) = SQRT(AM2)
8765             IDRES(I)     = IDRES(I)/100
8766             IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8767      &          (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8768                WRITE(LOUT,'(1X,A,4G10.3)')
8769      &          'EVTRES: inconsistent chain-masses',
8770      &          PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8771                GOTO 9999
8772             ENDIF
8773          ENDIF
8774     1 CONTINUE
8775     6 CONTINUE
8776       RETURN
8777
8778  9999 CONTINUE
8779       IREJ = 1
8780       RETURN
8781       END
8782
8783 *$ CREATE DT_GETSPT.FOR
8784 *COPY DT_GETSPT
8785 *
8786 *===getspt=============================================================*
8787 *
8788       SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8789      &                  PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8790      &                  AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8791
8792 ************************************************************************
8793 * This version dated 12.12.94 is written by S. Roesler                 *
8794 ************************************************************************
8795
8796       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8797       SAVE
8798
8799       PARAMETER ( LINP = 10 ,
8800      &            LOUT = 6 ,
8801      &            LDAT = 9 )
8802
8803       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8804
8805 * various options for treatment of partons (DTUNUC 1.x)
8806 * (chain recombination, Cronin,..)
8807       LOGICAL LCO2CR,LINTPT
8808       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8809      &                LCO2CR,LINTPT
8810
8811 * flags for input different options
8812       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8813       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8814      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8815
8816 * flags for diffractive interactions (DTUNUC 1.x)
8817       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8818
8819       DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8820      &          PT2(4),PT2I(4),P1(4),P2(4),
8821      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8822      &          PTOTI(4),PTOTF(4),DIFF(4)
8823
8824       IC   = 0
8825       IREJ = 0
8826 C     B33P = 4.0D0
8827 C     B33T = 4.0D0
8828 C     IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8829 C     IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8830       REDU = 1.0D0
8831 C     B33P = 3.5D0
8832 C     B33T = 3.5D0
8833       B33P = 4.0D0
8834       B33T = 4.0D0
8835       IF (IDIFF.NE.0) THEN
8836          B33P = 16.0D0
8837          B33T = 16.0D0
8838       ENDIF
8839
8840       DO 1 I=1,4
8841          PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8842          PP1(I)   = PP1I(I)
8843          PP2(I)   = PP2I(I)
8844          PT1(I)   = PT1I(I)
8845          PT2(I)   = PT2I(I)
8846     1 CONTINUE
8847 * get initial chain masses
8848       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8849      &                               +(PP1(3)+PT1(3))**2)
8850       ECH   = PP1(4)+PT1(4)
8851       AM1   = (ECH+PTOCH)*(ECH-PTOCH)
8852       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8853      &                               +(PP2(3)+PT2(3))**2)
8854       ECH   = PP2(4)+PT2(4)
8855       AM2   = (ECH+PTOCH)*(ECH-PTOCH)
8856       IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8857          IF (IOULEV(1).GT.0)
8858      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8859      &                              AM1,AM2
8860          GOTO 9999
8861       ENDIF
8862       AM1  = SQRT(AM1)
8863       AM2  = SQRT(AM2)
8864       AM1N = ZERO
8865       AM2N = ZERO
8866
8867       MODE = 0
8868 C      IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8869 C        MODE = 0
8870 C      ELSE
8871 C         MODE = 1
8872 C         IF (AM1.LT.0.6) THEN
8873 C            B33P = 10.0D0
8874 C         ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8875 CC           B33P = 4.0D0
8876 C         ENDIF
8877 C         IF (AM2.LT.0.6) THEN
8878 C            B33T = 10.0D0
8879 C         ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8880 CC           B33T = 4.0D0
8881 C         ENDIF
8882 C      ENDIF
8883
8884 * check chain masses for very low mass chains
8885 C     CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8886 C    &            AM1,DUM,-IDCH1,IREJ1)
8887 C     CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8888 C    &            AM2,DUM,-IDCH2,IREJ2)
8889 C     IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8890 C        B33P = 20.0D0
8891 C        B33T = 20.0D0
8892 C     ENDIF
8893
8894       JMSHL = IMSHL
8895
8896     2 CONTINUE
8897       IC = IC+1
8898       IF (MOD(IC,15).EQ.0) B33P  = 2.0D0*B33P
8899       IF (MOD(IC,15).EQ.0) B33T  = 2.0D0*B33T
8900       IF (MOD(IC,18).EQ.0) REDU  = 0.0D0
8901 C     IF (MOD(IC,19).EQ.0) JMSHL = 0
8902       IF (MOD(IC,20).EQ.0) GOTO 7
8903 C        WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8904 C        RETURN
8905 C        GOTO 9999
8906 C     ENDIF
8907
8908 * get transverse momentum
8909       IF (LINTPT) THEN
8910          ES   = -2.0D0/(B33P**2)
8911      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8912          HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8913          HPSP = HPSP*REDU
8914          ES   = -2.0D0/(B33T**2)
8915      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8916          HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8917          HPST = HPST*REDU
8918       ELSE
8919          HPSP = ZERO
8920          HPST = ZERO
8921       ENDIF
8922       CALL DT_DSFECF(SFE1,CFE1)
8923       CALL DT_DSFECF(SFE2,CFE2)
8924       IF (MODE.EQ.0) THEN
8925          PP1(1) = PP1I(1)+HPSP*CFE1
8926          PP1(2) = PP1I(2)+HPSP*SFE1
8927          PP2(1) = PP2I(1)-HPSP*CFE1
8928          PP2(2) = PP2I(2)-HPSP*SFE1
8929          PT1(1) = PT1I(1)+HPST*CFE2
8930          PT1(2) = PT1I(2)+HPST*SFE2
8931          PT2(1) = PT2I(1)-HPST*CFE2
8932          PT2(2) = PT2I(2)-HPST*SFE2
8933       ELSE
8934          PP1(1) = PP1I(1)+HPSP*CFE1
8935          PP1(2) = PP1I(2)+HPSP*SFE1
8936          PT1(1) = PT1I(1)-HPSP*CFE1
8937          PT1(2) = PT1I(2)-HPSP*SFE1
8938          PP2(1) = PP2I(1)+HPST*CFE2
8939          PP2(2) = PP2I(2)+HPST*SFE2
8940          PT2(1) = PT2I(1)-HPST*CFE2
8941          PT2(2) = PT2I(2)-HPST*SFE2
8942       ENDIF
8943
8944 * put partons on mass shell
8945       XMP1 = 0.0D0
8946       XMT1 = 0.0D0
8947       IF (JMSHL.EQ.1) THEN
8948
8949          XMP1 = PYMASS(IFPR1)
8950          XMT1 = PYMASS(IFTA1)
8951
8952       ENDIF
8953       CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8954       IF (IREJ1.NE.0) GOTO 2
8955       DO 3 I=1,4
8956          PTOTF(I) = P1(I)+P2(I)
8957          PP1(I)   = P1(I)
8958          PT1(I)   = P2(I)
8959     3 CONTINUE
8960       XMP2 = 0.0D0
8961       XMT2 = 0.0D0
8962       IF (JMSHL.EQ.1) THEN
8963
8964          XMP2 = PYMASS(IFPR2)
8965          XMT2 = PYMASS(IFTA2)
8966
8967       ENDIF
8968       CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8969       IF (IREJ1.NE.0) GOTO 2
8970       DO 4 I=1,4
8971          PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8972          PP2(I)   = P1(I)
8973          PT2(I)   = P2(I)
8974     4 CONTINUE
8975
8976 * check consistency
8977       DO 5 I=1,4
8978          DIFF(I) = PTOTI(I)-PTOTF(I)
8979     5 CONTINUE
8980       IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8981      &    (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8982          WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8983          GOTO 9999
8984       ENDIF
8985       PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8986       AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8987       PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8988       AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8989       PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8990       AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8991       PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8992       AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8993       IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8994      &    (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8995      &                                                           THEN
8996          WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8997      &     'GETSPT: inconsistent masses',
8998      &     AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8999 * sr 22.11.00: commented. It should only have inconsistent masses for
9000 * ultrahigh energies due to rounding problems
9001 C        GOTO 9999
9002       ENDIF
9003
9004 * get chain masses
9005       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
9006      &                               +(PP1(3)+PT1(3))**2)
9007       ECH   = PP1(4)+PT1(4)
9008       AM1N  = (ECH+PTOCH)*(ECH-PTOCH)
9009       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
9010      &                               +(PP2(3)+PT2(3))**2)
9011       ECH   = PP2(4)+PT2(4)
9012       AM2N  = (ECH+PTOCH)*(ECH-PTOCH)
9013       IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
9014          IF (IOULEV(1).GT.0)
9015      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
9016      &                              AM1N,AM2N
9017          GOTO 2
9018       ENDIF
9019       AM1N = SQRT(AM1N)
9020       AM2N = SQRT(AM2N)
9021
9022 * check chain masses for very low mass chains
9023       CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
9024      &            AM1N,DUM,-IDCH1,IREJ1)
9025       IF (IREJ1.NE.0) GOTO 2
9026       CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
9027      &            AM2N,DUM,-IDCH2,IREJ2)
9028       IF (IREJ2.NE.0) GOTO 2
9029
9030     7 CONTINUE
9031       IF (AM1N.GT.ZERO) THEN
9032          AM1 = AM1N
9033          AM2 = AM2N
9034       ENDIF
9035       DO 6 I=1,4
9036          PP1I(I)   = PP1(I)
9037          PP2I(I)   = PP2(I)
9038          PT1I(I)   = PT1(I)
9039          PT2I(I)   = PT2(I)
9040     6 CONTINUE
9041
9042       RETURN
9043
9044  9999 CONTINUE
9045       IREJ = 1
9046       RETURN
9047       END
9048
9049 *$ CREATE DT_SAPTRE.FOR
9050 *COPY DT_SAPTRE
9051 *
9052 *===saptre=============================================================*
9053 *
9054       SUBROUTINE DT_SAPTRE(IDX1,IDX2)
9055
9056 ************************************************************************
9057 * p-t sampling for two-resonance systems. ("BAMJET-like" method)       *
9058 *        IDX1,IDX2       indices of resonances ("chains") in DTEVT1    *
9059 * Adopted from the original SAPTRE written by J. Ranft.                *
9060 * This version dated 18.01.95 is written by S. Roesler                 *
9061 ************************************************************************
9062
9063       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9064       SAVE
9065
9066       PARAMETER ( LINP = 10 ,
9067      &            LOUT = 6 ,
9068      &            LDAT = 9 )
9069
9070       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
9071
9072 * event history
9073
9074       PARAMETER (NMXHKK=200000)
9075
9076       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9077      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9078      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9079
9080 * extended event history
9081       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9082      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9083      &                IHIST(2,NMXHKK)
9084
9085 * flags for input different options
9086       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9087       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9088      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9089
9090       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
9091
9092       DATA B3 /4.0D0/
9093
9094       ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
9095       ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
9096       ESMAX  = MIN(ESMAX1,ESMAX2)
9097       IF (ESMAX.LE.0.05D0) RETURN
9098
9099       HMA    = PHKK(5,IDX1)
9100       DO 1 K=1,4
9101          PA1(K) = PHKK(K,IDX1)
9102          PA2(K) = PHKK(K,IDX2)
9103     1 CONTINUE
9104
9105       IF (LEMCCK) THEN
9106          CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
9107          CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
9108       ENDIF
9109
9110       EXEB   = 0.0D0
9111       IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
9112       BEXP   = HMA*(1.0D0-EXEB)/B3
9113       AXEXP  = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
9114       WA     = AXEXP/(BEXP+AXEXP)
9115       XAB    = DT_RNDM(WA)
9116    10 CONTINUE
9117 * ES is the transverse kinetic energy
9118       IF (XAB.LT.WA)THEN
9119         X  = DT_RNDM(WA)
9120         Y  = DT_RNDM(WA)
9121         ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
9122       ELSE
9123         X  = DT_RNDM(Y)
9124         ES = ABS(-LOG(X+TINY7)/B3)
9125       ENDIF
9126       IF (ES.GT.ESMAX) GOTO 10
9127       ES  = ES+HMA
9128 * transverse momentum
9129       HPS = SQRT((ES-HMA)*(ES+HMA))
9130
9131       CALL DT_DSFECF(SFE,CFE)
9132       HPX = HPS*CFE
9133       HPY = HPS*SFE
9134       PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
9135       PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
9136       IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
9137
9138 C     PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
9139 C     PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
9140       PA1(1) = PA1(1)+HPX
9141       PA1(2) = PA1(2)+HPY
9142       PA2(1) = PA2(1)-HPX
9143       PA2(2) = PA2(2)-HPY
9144
9145 * put resonances on mass-shell again
9146       XM1 = PHKK(5,IDX1)
9147       XM2 = PHKK(5,IDX2)
9148       CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
9149       IF (IREJ1.NE.0) RETURN
9150
9151       IF (LEMCCK) THEN
9152          CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
9153          CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
9154          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
9155          IF (IREJ1.NE.0) RETURN
9156       ENDIF
9157
9158       DO 2 K=1,4
9159          PHKK(K,IDX1) = P1(K)
9160          PHKK(K,IDX2) = P2(K)
9161     2 CONTINUE
9162
9163       RETURN
9164       END
9165
9166 *$ CREATE DT_CRONIN.FOR
9167 *COPY DT_CRONIN
9168 *
9169 *===cronin=============================================================*
9170 *
9171       SUBROUTINE DT_CRONIN(INCL)
9172
9173 ************************************************************************
9174 * Cronin-Effect. Multiple scattering of partons at chain ends.         *
9175 *             INCL = 1     multiple sc. in projectile                  *
9176 *                  = 2     multiple sc. in target                      *
9177 * This version dated 05.01.96 is written by S. Roesler.                *
9178 ************************************************************************
9179
9180       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9181       SAVE
9182
9183       PARAMETER ( LINP = 10 ,
9184      &            LOUT = 6 ,
9185      &            LDAT = 9 )
9186
9187       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9188
9189 * event history
9190
9191       PARAMETER (NMXHKK=200000)
9192
9193       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9194      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9195      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9196
9197 * extended event history
9198       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9199      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9200      &                IHIST(2,NMXHKK)
9201
9202 * rejection counter
9203       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9204      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9205      &                IREXCI(3),IRDIFF(2),IRINC
9206
9207 * Glauber formalism: collision properties
9208       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9209      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
9210      &                NCP,NCT
9211       DIMENSION R(3),PIN(4),POUT(4),DEV(4)
9212
9213       DO 1 K=1,4
9214          DEV(K) = ZERO
9215     1 CONTINUE
9216
9217       DO 2 I=NPOINT(2),NHKK
9218          IF (ISTHKK(I).LT.0) THEN
9219 * get z-position of the chain
9220             R(1) = VHKK(1,I)*1.0D12
9221             IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
9222             R(2) = VHKK(2,I)*1.0D12
9223             IDXNU = JMOHKK(1,I)
9224             IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
9225      &                             IDXNU = JMOHKK(1,I-1)
9226             IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
9227      &                             IDXNU = JMOHKK(1,I+1)
9228             R(3) = VHKK(3,IDXNU)*1.0D12
9229 * position of target parton the chain is connected to
9230             DO 3 K=1,4
9231                PIN(K) = PHKK(K,I)
9232     3       CONTINUE
9233 * multiple scattering of parton with DTEVT1-index I
9234             CALL DT_CROMSC(PIN,R,POUT,INCL)
9235 **testprint
9236 C           IF (NEVHKK.EQ.5) THEN
9237 C              AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
9238 C              AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
9239 C              AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
9240 C              AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
9241 C              WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
9242 C              WRITE(6,'(A,4E15.5)')'PIN:       ',PIN
9243 C              WRITE(6,'(A,4E15.5)')'POUT:      ',POUT
9244 C           ENDIF
9245 **
9246 * increase accumulator by energy-momentum difference
9247             DO 4 K=1,4
9248                DEV(K)    = DEV(K)+POUT(K)-PIN(K)
9249                PHKK(K,I) = POUT(K)
9250     4       CONTINUE
9251             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9252      &                           PHKK(2,I)**2-PHKK(3,I)**2))
9253          ENDIF
9254     2 CONTINUE
9255
9256 * dump accumulator to momenta of valence partons
9257       NVAL = 0
9258       ETOT = 0.0D0
9259       DO 5 I=NPOINT(2),NHKK
9260          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9261             NVAL = NVAL+1
9262             ETOT = ETOT+PHKK(4,I)
9263          ENDIF
9264     5 CONTINUE
9265 C     WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
9266  1000 FORMAT(1X,'CRONIN :  number of val. partons ',I4,/,
9267      &       9X,4E12.4)
9268       DO 6 I=NPOINT(2),NHKK
9269          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9270             E = PHKK(4,I)
9271             DO 7 K=1,4
9272 C              PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
9273                PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
9274     7       CONTINUE
9275             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9276      &                           PHKK(2,I)**2-PHKK(3,I)**2))
9277          ENDIF
9278     6 CONTINUE
9279
9280       RETURN
9281       END
9282
9283 *$ CREATE DT_CROMSC.FOR
9284 *COPY DT_CROMSC
9285 *
9286 *===cromsc=============================================================*
9287 *
9288       SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
9289
9290 ************************************************************************
9291 * Cronin-Effect. Multiple scattering of one parton passing through     *
9292 * nuclear matter.                                                      *
9293 *            PIN(4)       input 4-momentum of parton                   *
9294 *            POUT(4)      4-momentum of parton after mult. scatt.      *
9295 *            R(3)         spatial position of parton in target nucleus *
9296 *            INCL = 1     multiple sc. in projectile                   *
9297 *                 = 2     multiple sc. in target                       *
9298 * This is a revised version of the original version written by J. Ranft*
9299 * This version dated 17.01.95 is written by S. Roesler.                *
9300 ************************************************************************
9301
9302       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9303       SAVE
9304
9305       PARAMETER ( LINP = 10 ,
9306      &            LOUT = 6 ,
9307      &            LDAT = 9 )
9308
9309       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9310
9311       LOGICAL LSTART
9312
9313 * rejection counter
9314       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9315      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9316      &                IREXCI(3),IRDIFF(2),IRINC
9317
9318 * Glauber formalism: collision properties
9319       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9320      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
9321      &                NCP,NCT
9322
9323 * various options for treatment of partons (DTUNUC 1.x)
9324 * (chain recombination, Cronin,..)
9325       LOGICAL LCO2CR,LINTPT
9326       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9327      &                LCO2CR,LINTPT
9328
9329       DIMENSION PIN(4),POUT(4),R(3)
9330
9331       DATA LSTART /.TRUE./
9332
9333       IRCRON(1) = IRCRON(1)+1
9334
9335       IF (LSTART) THEN
9336          WRITE(LOUT,1000) CRONCO
9337  1000    FORMAT(/,1X,'CROMSC:  multiple scattering of chain ends',
9338      &          ' treated',/,10X,'with parameter CRONCO = ',F5.2)
9339          LSTART = .FALSE.
9340       ENDIF
9341
9342       NCBACK = 0
9343       RNCL   = RPROJ
9344       IF (INCL.EQ.2) RNCL = RTARG
9345
9346 * Lorentz-transformation into Lab.
9347       MODE = -(INCL+1)
9348       CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
9349
9350       PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
9351       IF (PTOT.LE.8.0D0) GOTO 9997
9352
9353 * direction cosines of parton before mult. scattering
9354       COSX = PIN(1)/PTOT
9355       COSY = PIN(2)/PTOT
9356       COSZ = PZ/PTOT
9357
9358       RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
9359       IF (RTESQ.GE.-TINY3) GOTO 9999
9360
9361 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
9362 * in the direction of particle motion
9363
9364       A    = COSX*R(1)+COSY*R(2)+COSZ*R(3)
9365       TMP  = A**2-RTESQ
9366       IF (TMP.LT.ZERO) GOTO 9998
9367       DIST = -A+SQRT(TMP)
9368
9369 * multiple scattering angle
9370       THETO = CRONCO*SQRT(DIST)/PTOT
9371       IF (THETO.GT.0.1D0) THETO=0.1D0
9372
9373     1 CONTINUE
9374 * Gaussian sampling of spatial angle
9375       CALL DT_RANNOR(R1,R2)
9376       THETA = ABS(R1*THETO)
9377       IF (THETA.GT.0.3D0) GOTO 9997
9378       CALL DT_DSFECF(SFE,CFE)
9379       COSTH = COS(THETA)
9380       SINTH = SIN(THETA)
9381
9382 * new direction cosines
9383       CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
9384      &                               COSXN,COSYN,COSZN)
9385
9386       POUT(1) = COSXN*PTOT
9387       POUT(2) = COSYN*PTOT
9388       PZ      = COSZN*PTOT
9389 * Lorentz-transformation into nucl.-nucl. cms
9390       MODE = INCL+1
9391       CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
9392
9393 C     IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
9394 C     IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
9395       IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
9396          THETO = THETO/2.0D0
9397          NCBACK = NCBACK+1
9398          IF (MOD(NCBACK,200).EQ.0) THEN
9399             WRITE(LOUT,1001) THETO,PIN,POUT
9400  1001       FORMAT(1X,'CROMSC: inconsistent scattering angle ',
9401      &             E12.4,/,1X,'        PIN :',4E12.4,/,
9402      &             1X,'       POUT:',4E12.4)
9403             GOTO 9997
9404          ENDIF
9405          GOTO 1
9406       ENDIF
9407
9408       RETURN
9409
9410  9997 IRCRON(2) = IRCRON(2)+1
9411       GOTO 9999
9412  9998 IRCRON(3) = IRCRON(3)+1
9413
9414  9999 CONTINUE
9415       DO 100 K=1,4
9416          POUT(K) = PIN(K)
9417   100 CONTINUE
9418       RETURN
9419       END
9420
9421 *$ CREATE DT_COM2CR.FOR
9422 *COPY DT_COM2CR
9423 *
9424 *===com2sr=============================================================*
9425 *
9426       SUBROUTINE DT_COM2CR
9427
9428 ************************************************************************
9429 * COMbine q-aq chains to Color Ropes (qq-aqaq).                        *
9430 *        CUTOF      parameter determining minimum number of not        *
9431 *                   combined q-aq chains                               *
9432 * This subroutine replaces KKEVCC etc.                                 *
9433 * This version dated 11.01.95 is written by S. Roesler.                *
9434 ************************************************************************
9435
9436       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9437       SAVE
9438
9439       PARAMETER ( LINP = 10 ,
9440      &            LOUT = 6 ,
9441      &            LDAT = 9 )
9442
9443 * event history
9444
9445       PARAMETER (NMXHKK=200000)
9446
9447       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9448      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9449      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9450
9451 * extended event history
9452       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9453      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9454      &                IHIST(2,NMXHKK)
9455
9456 * statistics
9457       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9458      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9459      &                ICEVTG(8,0:30)
9460
9461 * various options for treatment of partons (DTUNUC 1.x)
9462 * (chain recombination, Cronin,..)
9463       LOGICAL LCO2CR,LINTPT
9464       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9465      &                LCO2CR,LINTPT
9466
9467       DIMENSION IDXQA(248),IDXAQ(248)
9468
9469       ICCHAI(1,9) = ICCHAI(1,9)+1
9470       NQA = 0
9471       NAQ = 0
9472 * scan DTEVT1 for q-aq, aq-q chains
9473       DO 10 I=NPOINT(3),NHKK
9474 * skip "chains" which are resonances
9475          IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
9476             MO1 = JMOHKK(1,I)
9477             MO2 = JMOHKK(2,I)
9478             IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
9479 * q-aq, aq-q chain found, keep index
9480                IF (IDHKK(MO1).GT.0) THEN
9481                   NQA = NQA+1
9482                   IDXQA(NQA) = I
9483                ELSE
9484                   NAQ = NAQ+1
9485                   IDXAQ(NAQ) = I
9486                ENDIF
9487             ENDIF
9488          ENDIF
9489    10 CONTINUE
9490
9491 * minimum number of q-aq chains requested for the same projectile/
9492 * target
9493       NCHMIN = IDT_NPOISS(CUTOF)
9494
9495 * combine q-aq chains of the same projectile
9496       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
9497 * combine q-aq chains of the same target
9498       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9499 * combine aq-q chains of the same projectile
9500       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9501 * combine aq-q chains of the same target
9502       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9503
9504       RETURN
9505       END
9506
9507 *$ CREATE DT_SCN4CR.FOR
9508 *COPY DT_SCN4CR
9509 *
9510 *===scn4cr=============================================================*
9511 *
9512       SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9513
9514 ************************************************************************
9515 * SCan q-aq chains for Color Ropes.                                    *
9516 * This version dated 11.01.95 is written by S. Roesler.                *
9517 ************************************************************************
9518
9519       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9520       SAVE
9521
9522       PARAMETER ( LINP = 10 ,
9523      &            LOUT = 6 ,
9524      &            LDAT = 9 )
9525
9526 * event history
9527
9528       PARAMETER (NMXHKK=200000)
9529
9530       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9531      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9532      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9533
9534 * extended event history
9535       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9536      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9537      &                IHIST(2,NMXHKK)
9538
9539       DIMENSION IDXCH(248),IDXJN(248)
9540
9541       DO 1 I=1,NCH
9542          IF (IDXCH(I).GT.0) THEN
9543             NJOIN = 1
9544             IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9545             IDXJN(NJOIN) = I
9546             IF (I.LT.NCH) THEN
9547                DO 2 J=I+1,NCH
9548                   IF (IDXCH(J).GT.0) THEN
9549                      IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9550                      IF (IDXMO.EQ.IDXMO1) THEN
9551                         NJOIN = NJOIN+1
9552                         IDXJN(NJOIN) = J
9553                      ENDIF
9554                   ENDIF
9555     2          CONTINUE
9556             ENDIF
9557             IF (NJOIN.GE.NCHMIN+2) THEN
9558                NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9559                DO 3 J=1,2*NJ,2
9560                   CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9561                   IF (IREJ1.NE.0) GOTO 3
9562                   IDXCH(IDXJN(J))   = 0
9563                   IDXCH(IDXJN(J+1)) = 0
9564     3          CONTINUE
9565             ENDIF
9566          ENDIF
9567     1 CONTINUE
9568
9569       RETURN
9570       END
9571
9572 *$ CREATE DT_JOIN.FOR
9573 *COPY DT_JOIN
9574 *
9575 *===join===============================================================*
9576 *
9577       SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9578
9579 ************************************************************************
9580 * This subroutine joins two q-aq chains to one qq-aqaq chain.          *
9581 *     IDX1, IDX2       DTEVT1 indices of chains to be joined           *
9582 * This version dated 11.01.95 is written by S. Roesler.                *
9583 ************************************************************************
9584
9585       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9586       SAVE
9587
9588       PARAMETER ( LINP = 10 ,
9589      &            LOUT = 6 ,
9590      &            LDAT = 9 )
9591
9592 * event history
9593
9594       PARAMETER (NMXHKK=200000)
9595
9596       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9597      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9598      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9599
9600 * extended event history
9601       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9602      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9603      &                IHIST(2,NMXHKK)
9604
9605 * flags for input different options
9606       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9607       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9608      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9609
9610 * statistics
9611       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9612      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9613      &                ICEVTG(8,0:30)
9614
9615       DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9616
9617       IREJ   = 0
9618
9619       IDX(1) = IDX1
9620       IDX(2) = IDX2
9621       DO 1 I=1,2
9622          DO 2 J=1,2
9623             MO(I,J) = JMOHKK(J,IDX(I))
9624             ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9625     2    CONTINUE
9626     1 CONTINUE
9627
9628 * check consistency
9629       IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9630      &    (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9631      &    ((ID(1,1)*ID(2,1)).LT.0).OR.
9632      &    ((ID(1,2)*ID(2,2)).LT.0)) THEN
9633          WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9634      &                    MO(2,2)
9635  1000    FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9636      &             2I5,' chain ',I4,':',2I5)
9637       ENDIF
9638
9639 * join chains
9640       DO 3 K=1,4
9641          PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9642          PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9643     3 CONTINUE
9644       IF1  = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9645       IF2  = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9646       IST1 = ISTHKK(MO(1,1))
9647       IST2 = ISTHKK(MO(1,2))
9648
9649 * put partons again on mass shell
9650       XM1 = 0.0D0
9651       XM2 = 0.0D0
9652       IF (IMSHL.EQ.1) THEN
9653
9654          XM1 = PYMASS(IF1)
9655          XM2 = PYMASS(IF2)
9656
9657       ENDIF
9658       CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9659       IF (IREJ1.NE.0) GOTO 9999
9660       DO 4 I=1,4
9661          PP(I) = P1(I)
9662          PT(I) = P2(I)
9663     4 CONTINUE
9664
9665 * store new partons in DTEVT1
9666       CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9667      &                                                       0,0,0)
9668       CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9669      &                                                       0,0,0)
9670       DO 5 K=1,4
9671          PCH(K) = PP(K)+PT(K)
9672     5 CONTINUE
9673
9674 * check new chain for lower mass limit
9675       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9676          AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9677          CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9678      &               AMCH,AMCHN,3,IREJ1)
9679          IF (IREJ1.NE.0) THEN
9680             NHKK = NHKK-2
9681             GOTO 9999
9682          ENDIF
9683       ENDIF
9684
9685       ICCHAI(2,9) = ICCHAI(2,9)+1
9686 * store new chain in DTEVT1
9687       KCH = 191
9688       CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9689       IDHKK(IDX(1)) = 22222
9690       IDHKK(IDX(2)) = 22222
9691 * special treatment for space-time coordinates
9692       DO 6 K=1,4
9693          VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9694          WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9695     6 CONTINUE
9696       RETURN
9697
9698  9999 CONTINUE
9699       IREJ = 1
9700       RETURN
9701       END
9702 *$ CREATE DT_XSGLAU.FOR
9703 *COPY DT_XSGLAU
9704 *
9705 *===xsglau=============================================================*
9706 *
9707       SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9708
9709 ************************************************************************
9710 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9711 * Glauber's approach.                                                  *
9712 *  NA / NB     mass numbers of proj./target nuclei                     *
9713 *  JJPROJ      bamjet-index of projectile (=1 in case of proj.nucleus) *
9714 *  XI,Q2I,ECMI kinematical variables x, Q^2, E_cm                      *
9715 *  IE,IQ       indices of energy and virtuality (the latter for gamma  *
9716 *              projectiles only)                                       *
9717 *  NIDX        index of projectile/target nucleus                      *
9718 * This version dated 17.3.98  is written by S. Roesler                 *
9719 ************************************************************************
9720
9721       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9722       SAVE
9723
9724       PARAMETER ( LINP = 10 ,
9725      &            LOUT = 6 ,
9726      &            LDAT = 9 )
9727
9728       COMPLEX*16 CZERO,CONE,CTWO
9729       CHARACTER*12 CFILE
9730       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9731      &           ONETHI=ONE/THREE,TINY25=1.0D-25)
9732       PARAMETER (TWOPI  = 6.283185307179586454D+00,
9733      &           PI     = TWOPI/TWO,
9734      &           GEV2MB = 0.38938D0,
9735      &           GEV2FM = 0.1972D0,
9736      &           ALPHEM = ONE/137.0D0,
9737 * proton mass
9738      &           AMP    = 0.938D0,
9739      &           AMP2   = AMP**2,
9740 * approx. nucleon radius
9741      &           RNUCLE = 1.12D0)
9742
9743 * particle properties (BAMJET index convention)
9744       CHARACTER*8  ANAME
9745       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9746      &                IICH(210),IIBAR(210),K1(210),K2(210)
9747
9748       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9749
9750       PARAMETER ( MAXNCL = 260,
9751
9752      &            MAXVQU = MAXNCL,
9753      &            MAXSQU = 20*MAXVQU,
9754      &            MAXINT = MAXVQU+MAXSQU)
9755
9756 * Glauber formalism: parameters
9757       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9758      &                BMAX(NCOMPX),BSTEP(NCOMPX),
9759      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9760      &                NSITEB,NSTATB
9761
9762 * Glauber formalism: cross sections
9763       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9764      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9765      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9766      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9767      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9768      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9769      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9770      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9771      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9772      &                BSLOPE,NEBINI,NQBINI
9773
9774 * Glauber formalism: flags and parameters for statistics
9775       LOGICAL LPROD
9776       CHARACTER*8 CGLB
9777       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9778
9779 * nucleon-nucleon event-generator
9780       CHARACTER*8 CMODEL
9781       LOGICAL LPHOIN
9782       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9783
9784 * VDM parameter for photon-nucleus interactions
9785       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9786
9787 * parameters for hA-diffraction
9788       COMMON /DTDIHA/ DIBETA,DIALPH
9789
9790       COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9791      &           OMPP11,OMPP12,OMPP21,OMPP22,
9792      &           DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9793      &           PPTMP1,PPTMP2
9794       COMPLEX*16 C,CA,CI
9795       DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9796      &          COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9797      &          BPROD(KSITEB)
9798
9799       PARAMETER (NPOINT=16)
9800       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9801
9802       LOGICAL LFIRST,LOPEN
9803       DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9804
9805       NTARG = ABS(NIDX)
9806 * for quasi-elastic neutrino scattering set projectile to proton
9807 * it should not have an effect since the whole Glauber-formalism is
9808 * not needed for these interactions..
9809       IF (MCGENE.EQ.4) THEN
9810          IJPROJ = 1
9811       ELSE
9812          IJPROJ = JJPROJ
9813       ENDIF
9814
9815       IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9816          I = INDEX(CGLB,' ')
9817          IF (I.EQ.0) THEN
9818             CFILE = CGLB//'.glb'
9819             OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9820          ELSEIF (I.GT.1) THEN
9821             CFILE = CGLB(1:I-1)//'.glb'
9822             OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9823          ELSE
9824             STOP 'XSGLAU 1'
9825          ENDIF
9826          LOPEN = .TRUE.
9827       ENDIF
9828
9829       CZERO  = DCMPLX(ZERO,ZERO)
9830       CONE   = DCMPLX(ONE,ZERO)
9831       CTWO   = DCMPLX(TWO,ZERO)
9832       NEBINI = IE
9833       NQBINI = IQ
9834
9835 * re-define kinematics
9836       S  = ECMI**2
9837       Q2 = Q2I
9838       X  = XI
9839 *  g(Q2=0)-A, h-A, A-A scattering
9840       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9841          Q2 = 0.0001D0
9842          X  = Q2/(S+Q2-AMP2)
9843 *  g(Q2>0)-A scattering
9844       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9845          X  = Q2/(S+Q2-AMP2)
9846       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9847          Q2 = (S-AMP2)*X/(ONE-X)
9848       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9849          S  = Q2*(ONE-X)/X+AMP2
9850       ELSE
9851          WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9852          STOP
9853       ENDIF
9854       ECMNN(IE) = SQRT(S)
9855       Q2G(IQ)   = Q2
9856       XNU = (S+Q2-AMP2)/(TWO*AMP)
9857
9858 * parameters determining statistics in evaluating Glauber-xsection
9859       NSTATB = JSTATB
9860       NSITEB = JBINSB
9861       IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9862
9863 * set up interaction geometry (common /DTGLAM/)
9864 *  projectile/target radii
9865       RPRNCL = DT_RNCLUS(NA)
9866       RTANCL = DT_RNCLUS(NB)
9867       IF (IJPROJ.EQ.7) THEN
9868          RASH(1) = ZERO
9869          RBSH(NTARG) = RTANCL
9870          BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9871       ELSE
9872          IF (NIDX.LE.-1) THEN
9873             RASH(1)     = RPRNCL
9874             RBSH(NTARG) = RTANCL
9875             BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9876          ELSE
9877             RASH(NTARG) = RPRNCL
9878             RBSH(1)     = RTANCL
9879             BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9880          ENDIF
9881       ENDIF
9882 *  maximum impact-parameter
9883       BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9884
9885 * slope, rho ( Re(f(0))/Im(f(0)) )
9886       IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9887          IF (MCGENE.EQ.2) THEN
9888             ZERO1 = ZERO
9889             CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9890      &                                                   BSLOPE,0)
9891          ELSE
9892             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9893          ENDIF
9894          IF (ECMNN(IE).LE.3.0D0) THEN
9895             ROSH = -0.43D0
9896          ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9897             ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9898          ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9899             ROSH = 0.1D0
9900          ENDIF
9901       ELSEIF (IJPROJ.EQ.7) THEN
9902          ROSH = 0.1D0
9903       ELSE
9904          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9905          ROSH   = 0.01D0
9906       ENDIF
9907
9908 * projectile-nucleon xsection (in fm)
9909       IF (IJPROJ.EQ.7) THEN
9910          SIGSH = DT_SIGVP(X,Q2)/10.0D0
9911       ELSE
9912          ELAB  = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9913          PLAB  = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9914 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9915          DUMZER = ZERO
9916          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9917          SIGSH = SIGSH/10.0D0
9918       ENDIF
9919
9920 * parameters for projectile diffraction (hA scattering only)
9921       IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9922      &                               .AND.(DIBETA.GE.ZERO)) THEN
9923          ZERO1 = ZERO
9924          CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9925 C        DIBETA = SDIF1/STOT
9926          DIBETA = 0.2D0
9927          DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9928          IF (DIBETA.LE.ZERO) THEN
9929             ALPGAM = ONE
9930          ELSE
9931             ALPGAM = DIALPH/DIGAMM
9932          ENDIF
9933          FACDI1 = ONE-ALPGAM
9934          FACDI2 = ONE+ALPGAM
9935          FACDI  = SQRT(FACDI1*FACDI2)
9936          WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9937       ELSE
9938          DIBETA = -1.0D0
9939          DIALPH = ZERO
9940          DIGAMM = ZERO
9941          FACDI1 = ZERO
9942          FACDI2 = 2.0D0
9943          FACDI  = ZERO
9944       ENDIF
9945
9946 * initializations
9947       DO 10 I=1,NSITEB
9948          BSITE( 0,IQ,NTARG,I) = ZERO
9949          BSITE(IE,IQ,NTARG,I) = ZERO
9950          BPROD(I) = ZERO
9951    10 CONTINUE
9952       STOT  = ZERO
9953       STOT2 = ZERO
9954       SELA  = ZERO
9955       SELA2 = ZERO
9956       SQEP  = ZERO
9957       SQEP2 = ZERO
9958       SQET  = ZERO
9959       SQET2 = ZERO
9960       SQE2  = ZERO
9961       SQE22 = ZERO
9962       SPRO  = ZERO
9963       SPRO2 = ZERO
9964       SDEL  = ZERO
9965       SDEL2 = ZERO
9966       SDQE  = ZERO
9967       SDQE2 = ZERO
9968       FACN   = ONE/DBLE(NSTATB)
9969
9970       IPNT = 0
9971       RPNT = ZERO
9972
9973 *  initialize Gauss-integration for photon-proj.
9974       JPOINT = 1
9975       IF (IJPROJ.EQ.7) THEN
9976          IF (INTRGE(1).EQ.1) THEN
9977             AMLO2 = (3.0D0*AAM(13))**2
9978          ELSEIF (INTRGE(1).EQ.2) THEN
9979             AMLO2 = AAM(33)**2
9980          ELSE
9981             AMLO2 = AAM(96)**2
9982          ENDIF
9983          IF (INTRGE(2).EQ.1) THEN
9984             AMHI2 = S/TWO
9985          ELSEIF (INTRGE(2).EQ.2) THEN
9986             AMHI2 = S/4.0D0
9987          ELSE
9988             AMHI2 = S
9989          ENDIF
9990          AMHI20 = (ECMNN(IE)-AMP)**2
9991          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9992          XAMLO = LOG( AMLO2+Q2 )
9993          XAMHI = LOG( AMHI2+Q2 )
9994 **PHOJET105a
9995 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9996 **PHOJET112
9997
9998          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9999
10000 **
10001          JPOINT = NPOINT
10002 * ratio direct/total photon-nucleon xsection
10003          CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
10004       ENDIF
10005
10006 * read pre-initialized profile-function from file
10007       IF (IOGLB.EQ.1) THEN
10008          READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
10009          IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
10010             WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
10011      &                             NA,NB,NSTATB,NSITEB
10012  1000       FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
10013      &             ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
10014      &             ' (NA,NB,NSTATB,NSITEB) ',4I10)
10015             STOP
10016          ENDIF
10017          IF (LFIRST) WRITE(LOUT,1001) CFILE
10018  1001    FORMAT(/,' XSGLAU: impact parameter distribution read from ',
10019      &          'file ',A12,/)
10020          READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
10021      &                         XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
10022      &                         XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10023          READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
10024      &                         XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
10025      &                         XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10026          NLINES = INT(DBLE(NSITEB)/7.0D0)
10027          IF (NLINES.GT.0) THEN
10028             DO 21 I=1,NLINES
10029                ISTART = 7*I-6
10030                READ(LDAT,'(7E11.4)')
10031      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10032    21       CONTINUE
10033          ENDIF
10034          ISTART = 7*NLINES+1
10035          IF (ISTART.LE.NSITEB) THEN
10036             READ(LDAT,'(7E11.4)')
10037      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10038          ENDIF
10039          LFIRST = .FALSE.
10040          GOTO 100
10041 * variable projectile/target/energy runs:
10042 * read pre-initialized profile-functions from file
10043       ELSEIF (IOGLB.EQ.100) THEN
10044          CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
10045          GOTO 100
10046       ENDIF
10047
10048 * cross sections averaged over NSTATB nucleon configurations
10049       DO 11 IS=1,NSTATB
10050 C        IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
10051          STOTN = ZERO
10052          SELAN = ZERO
10053          SQEPN = ZERO
10054          SQETN = ZERO
10055          SQE2N = ZERO
10056          SPRON = ZERO
10057          SDELN = ZERO
10058          SDQEN = ZERO
10059
10060          IF (NIDX.LE.-1) THEN
10061             CALL DT_CONUCL(COOP1,NA,RASH(1),0)
10062             CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
10063             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10064                CALL DT_CONUCL(COOP2,NA,RASH(1),0)
10065                CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
10066             ENDIF
10067          ELSE
10068             CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
10069             CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
10070             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10071                CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
10072                CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
10073             ENDIF
10074          ENDIF
10075
10076 *  integration over impact parameter B
10077          DO 12 IB=1,NSITEB-1
10078             STOTB = ZERO
10079             SELAB = ZERO
10080             SQEPB = ZERO
10081             SQETB = ZERO
10082             SQE2B = ZERO
10083             SPROB = ZERO
10084             SDIR  = ZERO
10085             SDELB = ZERO
10086             SDQEB = ZERO
10087             B     = DBLE(IB)*BSTEP(NTARG)
10088             FACB  = 10.0D0*TWOPI*B*BSTEP(NTARG)
10089
10090 *   integration over M_V^2 for photon-proj.
10091             DO 14 IM=1,JPOINT
10092                PP11(1) = CONE
10093                PP12(1) = CONE
10094                PP21(1) = CONE
10095                PP22(1) = CONE
10096                IF (IJPROJ.EQ.7) THEN
10097                   DO 13 K=2,NB
10098                      PP11(K) = CONE
10099                      PP12(K) = CONE
10100                      PP21(K) = CONE
10101                      PP22(K) = CONE
10102    13             CONTINUE
10103                ENDIF
10104                SHI  = ZERO
10105                FACM = ONE
10106                DCOH = 1.0D10
10107
10108                IF (IJPROJ.EQ.7) THEN
10109                   AMV2 = EXP(ABSZX(IM))-Q2
10110                   AMV  = SQRT(AMV2)
10111                   IF (AMV2.LT.16.0D0) THEN
10112                      R = TWO
10113                   ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
10114                      R = 10.0D0/3.0D0
10115                   ELSE
10116                      R = 11.0D0/3.0D0
10117                   ENDIF
10118 *    define M_V dependent properties of nucleon scattering amplitude
10119 *     V_M-nucleon xsection
10120                   SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
10121                   SIGMV  = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
10122 *     slope-parametrisation a la Kaidalov
10123                   BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
10124      &                           +0.25D0*LOG(S/(AMV2+Q2)))
10125 *    coherence length
10126                   IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
10127 *    integration weight factor
10128                   FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
10129      &                  R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
10130                ENDIF
10131                GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10132                GAM = GSH
10133                IF (IJPROJ.EQ.7) THEN
10134                   RCA = GAM*SIGMV/TWOPI
10135                ELSE
10136                   RCA = GAM*SIGSH/TWOPI
10137                ENDIF
10138                FCA = -ROSH*RCA
10139                CA  = DCMPLX(RCA,FCA)
10140                CI  = CONE
10141
10142                DO 15 INA=1,NA
10143                   KK1  = 1
10144                   INT1 = 1
10145                   KK2  = 1
10146                   INT2 = 1
10147                   DO 16 INB=1,NB
10148 *    photon-projectile: check for supression by coherence length
10149                      IF (IJPROJ.EQ.7) THEN
10150                         IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
10151                            KK1  = INB
10152                            INT1 = INT1+1
10153                         ENDIF
10154                         IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
10155                            KK2  = INB
10156                            INT2 = INT2+1
10157                         ENDIF
10158                      ENDIF
10159
10160                      X11 = B+COOT1(1,INB)-COOP1(1,INA)
10161                      Y11 =   COOT1(2,INB)-COOP1(2,INA)
10162                      XY11 = GAM*(X11*X11+Y11*Y11)
10163                      IF (XY11.LE.15.0D0) THEN
10164                         C = CONE-CA*EXP(-XY11)
10165                         AR = DBLE(PP11(INT1))
10166                         AI = DIMAG(PP11(INT1))
10167                         IF (ABS(AR).LT.TINY25) AR = ZERO
10168                         IF (ABS(AI).LT.TINY25) AI = ZERO
10169                         PP11(INT1) = DCMPLX(AR,AI)
10170                         PP11(INT1) = PP11(INT1)*C
10171                         AR  = DBLE(C)
10172                         AI  = DIMAG(C)
10173                         SHI = SHI+LOG(AR*AR+AI*AI)
10174                      ENDIF
10175                      IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10176                         X12 = B+COOT2(1,INB)-COOP1(1,INA)
10177                         Y12 =   COOT2(2,INB)-COOP1(2,INA)
10178                         XY12 = GAM*(X12*X12+Y12*Y12)
10179                         IF (XY12.LE.15.0D0) THEN
10180                            C = CONE-CA*EXP(-XY12)
10181                            AR = DBLE(PP12(INT2))
10182                            AI = DIMAG(PP12(INT2))
10183                            IF (ABS(AR).LT.TINY25) AR = ZERO
10184                            IF (ABS(AI).LT.TINY25) AI = ZERO
10185                            PP12(INT2) = DCMPLX(AR,AI)
10186                            PP12(INT2) = PP12(INT2)*C
10187                         ENDIF
10188                         X21 = B+COOT1(1,INB)-COOP2(1,INA)
10189                         Y21 =   COOT1(2,INB)-COOP2(2,INA)
10190                         XY21 = GAM*(X21*X21+Y21*Y21)
10191                         IF (XY21.LE.15.0D0) THEN
10192                            C = CONE-CA*EXP(-XY21)
10193                            AR = DBLE(PP21(INT1))
10194                            AI = DIMAG(PP21(INT1))
10195                            IF (ABS(AR).LT.TINY25) AR = ZERO
10196                            IF (ABS(AI).LT.TINY25) AI = ZERO
10197                            PP21(INT1) = DCMPLX(AR,AI)
10198                            PP21(INT1) = PP21(INT1)*C
10199                         ENDIF
10200                         X22 = B+COOT2(1,INB)-COOP2(1,INA)
10201                         Y22 =   COOT2(2,INB)-COOP2(2,INA)
10202                         XY22 = GAM*(X22*X22+Y22*Y22)
10203                         IF (XY22.LE.15.0D0) THEN
10204                            C = CONE-CA*EXP(-XY22)
10205                            AR = DBLE(PP22(INT2))
10206                            AI = DIMAG(PP22(INT2))
10207                            IF (ABS(AR).LT.TINY25) AR = ZERO
10208                            IF (ABS(AI).LT.TINY25) AI = ZERO
10209                            PP22(INT2) = DCMPLX(AR,AI)
10210                            PP22(INT2) = PP22(INT2)*C
10211                         ENDIF
10212                      ENDIF
10213    16             CONTINUE
10214    15          CONTINUE
10215
10216                OMPP11 = CZERO
10217                OMPP21 = CZERO
10218                DIPP11 = CZERO
10219                DIPP21 = CZERO
10220                DO 17 K=1,INT1
10221                   IF (PP11(K).EQ.CZERO) THEN
10222                      PPTMP1 = CZERO
10223                      PPTMP2 = CZERO
10224                   ELSE
10225                      PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
10226                      PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
10227                   ENDIF
10228                   AVDIPP = 0.5D0*
10229      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10230                   OMPP11 = OMPP11+AVDIPP
10231 C                 OMPP11 = OMPP11+(CONE-PP11(K))
10232                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10233                   DIPP11 = DIPP11+AVDIPP
10234                   IF (PP21(K).EQ.CZERO) THEN
10235                      PPTMP1 = CZERO
10236                      PPTMP2 = CZERO
10237                   ELSE
10238                      PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
10239                      PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
10240                   ENDIF
10241                   AVDIPP = 0.5D0*
10242      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10243                   OMPP21 = OMPP21+AVDIPP
10244 C                 OMPP21 = OMPP21+(CONE-PP21(K))
10245                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10246                   DIPP21 = DIPP21+AVDIPP
10247    17          CONTINUE
10248                OMPP12 = CZERO
10249                OMPP22 = CZERO
10250                DIPP12 = CZERO
10251                DIPP22 = CZERO
10252                DO 18 K=1,INT2
10253                   IF (PP12(K).EQ.CZERO) THEN
10254                      PPTMP1 = CZERO
10255                      PPTMP2 = CZERO
10256                   ELSE
10257                      PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
10258                      PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
10259                   ENDIF
10260                   AVDIPP = 0.5D0*
10261      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10262                   OMPP12 = OMPP12+AVDIPP
10263 C                 OMPP12 = OMPP12+(CONE-PP12(K))
10264                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10265                   DIPP12 = DIPP12+AVDIPP
10266                   IF (PP22(K).EQ.CZERO) THEN
10267                      PPTMP1 = CZERO
10268                      PPTMP2 = CZERO
10269                   ELSE
10270                      PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
10271                      PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
10272                   ENDIF
10273                   AVDIPP = 0.5D0*
10274      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10275                   OMPP22 = OMPP22+AVDIPP
10276 C                 OMPP22 = OMPP22+(CONE-PP22(K))
10277                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10278                   DIPP22 = DIPP22+AVDIPP
10279    18          CONTINUE
10280
10281                SPROM = ONE-EXP(SHI)
10282                SPROB = SPROB+FACM*SPROM
10283                IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10284                   STOTM = DBLE(OMPP11+OMPP22)
10285                   SELAM = DBLE(OMPP11*DCONJG(OMPP22))
10286                   SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
10287                   SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
10288                   SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
10289                   SDELM = DBLE(DIPP11*DCONJG(DIPP22))
10290                   SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
10291                   STOTB = STOTB+FACM*STOTM
10292                   SELAB = SELAB+FACM*SELAM
10293                   SDELB = SDELB+FACM*SDELM
10294                   IF (NB.GT.1) THEN
10295                      SQEPB = SQEPB+FACM*SQEPM
10296                      SDQEB = SDQEB+FACM*SDQEM
10297                   ENDIF
10298                   IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
10299                   IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
10300                   IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
10301                ENDIF
10302
10303    14       CONTINUE
10304
10305             STOTN = STOTN+FACB*STOTB
10306             SELAN = SELAN+FACB*SELAB
10307             SQEPN = SQEPN+FACB*SQEPB
10308             SQETN = SQETN+FACB*SQETB
10309             SQE2N = SQE2N+FACB*SQE2B
10310             SPRON = SPRON+FACB*SPROB
10311             SDELN = SDELN+FACB*SDELB
10312             SDQEN = SDQEN+FACB*SDQEB
10313
10314             IF (IJPROJ.EQ.7) THEN
10315                BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
10316             ELSE
10317                IF (DIBETA.GT.ZERO) THEN
10318                   BPROD(IB+1)= BPROD(IB+1)
10319      &                        +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
10320                ELSE
10321                   BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
10322                ENDIF
10323             ENDIF
10324
10325    12    CONTINUE
10326
10327          STOT  = STOT +FACN*STOTN
10328          STOT2 = STOT2+FACN*STOTN**2
10329          SELA  = SELA +FACN*SELAN
10330          SELA2 = SELA2+FACN*SELAN**2
10331          SQEP  = SQEP +FACN*SQEPN
10332          SQEP2 = SQEP2+FACN*SQEPN**2
10333          SQET  = SQET +FACN*SQETN
10334          SQET2 = SQET2+FACN*SQETN**2
10335          SQE2  = SQE2 +FACN*SQE2N
10336          SQE22 = SQE22+FACN*SQE2N**2
10337          SPRO  = SPRO +FACN*SPRON
10338          SPRO2 = SPRO2+FACN*SPRON**2
10339          SDEL  = SDEL +FACN*SDELN
10340          SDEL2 = SDEL2+FACN*SDELN**2
10341          SDQE  = SDQE +FACN*SDQEN
10342          SDQE2 = SDQE2+FACN*SDQEN**2
10343
10344    11 CONTINUE
10345
10346 * final cross sections
10347 * 1) total
10348       XSTOT(IE,IQ,NTARG) = STOT
10349       IF (IJPROJ.EQ.7)
10350      &   XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
10351 * 2) elastic
10352       XSELA(IE,IQ,NTARG) = SELA
10353 * 3) quasi-el.: A+B-->A+X (excluding 2)
10354       XSQEP(IE,IQ,NTARG) = SQEP
10355 * 4) quasi-el.: A+B-->X+B (excluding 2)
10356       XSQET(IE,IQ,NTARG) = SQET
10357 * 5) quasi-el.: A+B-->X (excluding 2-4)
10358       XSQE2(IE,IQ,NTARG) = SQE2
10359 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
10360       IF (SDEL.GT.ZERO) THEN
10361          XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
10362       ELSE
10363          XSPRO(IE,IQ,NTARG) = SPRO
10364       ENDIF
10365 * 7) projectile diffraction (el. scatt. off target)
10366       XSDEL(IE,IQ,NTARG) = SDEL
10367 * 8) projectile diffraction (quasi-el. scatt. off target)
10368       XSDQE(IE,IQ,NTARG) = SDQE
10369 *  stat. errors
10370       XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
10371       XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
10372       XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
10373       XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
10374       XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
10375       XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
10376       XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
10377       XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
10378
10379       IF (IJPROJ.EQ.7) THEN
10380          BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
10381      &          -XSQEP(IE,IQ,NTARG)
10382       ELSE
10383          BNORM = XSPRO(IE,IQ,NTARG)
10384       ENDIF
10385       DO 19 I=2,NSITEB
10386          BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
10387          IF ((IE.EQ.1).AND.(IQ.EQ.1))
10388      &      BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
10389    19 CONTINUE
10390
10391 * write profile function data into file
10392       IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
10393          WRITE(LDAT,'(5I10,1P,E15.5)')
10394      &      IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
10395          WRITE(LDAT,'(1P,6E12.5)')
10396      &      XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
10397      &      XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10398          WRITE(LDAT,'(1P,6E12.5)')
10399      &      XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
10400      &      XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10401          NLINES = INT(DBLE(NSITEB)/7.0D0)
10402          IF (NLINES.GT.0) THEN
10403             DO 20 I=1,NLINES
10404                ISTART = 7*I-6
10405                WRITE(LDAT,'(1P,7E11.4)')
10406      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10407    20       CONTINUE
10408          ENDIF
10409          ISTART = 7*NLINES+1
10410          IF (ISTART.LE.NSITEB) THEN
10411             WRITE(LDAT,'(1P,7E11.4)')
10412      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10413          ENDIF
10414       ENDIF
10415
10416   100 CONTINUE
10417
10418 C     IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
10419
10420       RETURN
10421       END
10422
10423 *$ CREATE DT_GETBXS.FOR
10424 *COPY DT_GETBXS
10425 *
10426 *===getbxs=============================================================*
10427 *
10428       SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
10429
10430 ************************************************************************
10431 * Biasing in impact parameter space.                                   *
10432 *     XSFRAC = 0 :  BLO    - minimum impact parameter  (input)         *
10433 *                   BHI    - maximum impact parameter  (input)         *
10434 *                   XSFRAC - fraction of cross section corresponding   *
10435 *                            to impact parameter range (BLO,BHI)       *
10436 *                                                      (output)        *
10437 *     XSFRAC > 0 :  XSFRAC - fraction of cross section (input)         *
10438 *                   BHI    - maximum impact parameter giving requested *
10439 *                            fraction of cross section in impact       *
10440 *                            parameter range (0,BMAX)  (output)        *
10441 * This version dated 17.03.00  is written by S. Roesler                *
10442 ************************************************************************
10443
10444       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10445       SAVE
10446
10447       PARAMETER ( LINP = 10 ,
10448      &            LOUT = 6 ,
10449      &            LDAT = 9 )
10450
10451       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10452
10453 * Glauber formalism: parameters
10454       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10455      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10456      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10457      &                NSITEB,NSTATB
10458
10459       NTARG = ABS(NIDX)
10460       IF (XSFRAC.LE.0.0D0) THEN
10461          ILO    = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
10462          IHI    = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
10463          IF (ILO.GE.IHI) THEN
10464             XSFRAC = 0.0D0
10465             RETURN
10466          ENDIF
10467          IF (ILO.EQ.NSITEB-1) THEN
10468             FRCLO = BSITE(0,1,NTARG,NSITEB)
10469          ELSE
10470             FRCLO = BSITE(0,1,NTARG,ILO+1)
10471      &              +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
10472      &              *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
10473          ENDIF
10474          IF (IHI.EQ.NSITEB-1) THEN
10475             FRCHI = BSITE(0,1,NTARG,NSITEB)
10476          ELSE
10477             FRCHI = BSITE(0,1,NTARG,IHI+1)
10478      &              +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
10479      &              *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
10480          ENDIF
10481          XSFRAC = FRCHI-FRCLO
10482       ELSE
10483          BLO = 0.0D0
10484          BHI = BMAX(NTARG)
10485          DO 1 I=1,NSITEB-1
10486             IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
10487                FAC = (XSFRAC              -BSITE(0,1,NTARG,I))/
10488      &               (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
10489                BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
10490                GOTO 2
10491             ENDIF
10492     1    CONTINUE
10493     2    CONTINUE
10494       ENDIF
10495
10496       RETURN
10497       END
10498
10499 *$ CREATE DT_CONUCL.FOR
10500 *COPY DT_CONUCL
10501 *
10502 *===conucl=============================================================*
10503 *
10504       SUBROUTINE DT_CONUCL(X,N,R,MODE)
10505
10506 ************************************************************************
10507 * Calculation of coordinates of nucleons within nuclei.                *
10508 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10509 *        N / R    number of nucleons / radius of nucleus   (input)     *
10510 *        MODE = 0 coordinates not sorted                               *
10511 *             = 1 coordinates sorted with increasing X(3,i)            *
10512 *             = 2 coordinates sorted with decreasing X(3,i)            *
10513 * This version dated 26.10.95 is revised by S. Roesler                 *
10514 ************************************************************************
10515
10516       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10517       SAVE
10518
10519       PARAMETER ( LINP = 10 ,
10520      &            LOUT = 6 ,
10521      &            LDAT = 9 )
10522
10523       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10524      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10525
10526       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10527
10528       PARAMETER (NSRT=10)
10529       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10530       DIMENSION X(3,N),XTMP(3,260)
10531
10532       CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10533
10534       IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10535          K = 0
10536          DO 1 I=1,NSRT
10537             IF (MODE.EQ.2) THEN
10538                ISRT = NSRT+1-I
10539             ELSE
10540                ISRT = I
10541             ENDIF
10542             K1 = K
10543             DO 2 J=1,ICSRT(ISRT)
10544                K = K+1
10545                X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10546                X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10547                X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10548     2       CONTINUE
10549             IF (ICSRT(ISRT).GT.1) THEN
10550                I0 = K1+1
10551                I1 = K
10552                CALL DT_SORT(X,N,I0,I1,MODE)
10553             ENDIF
10554     1    CONTINUE
10555       ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10556          DO 3 I=1,N
10557             X(1,I) = XTMP(1,I)
10558             X(2,I) = XTMP(2,I)
10559             X(3,I) = XTMP(3,I)
10560     3    CONTINUE
10561          CALL DT_SORT(X,N,1,N,MODE)
10562       ELSE
10563          DO 4 I=1,N
10564             X(1,I) = XTMP(1,I)
10565             X(2,I) = XTMP(2,I)
10566             X(3,I) = XTMP(3,I)
10567     4    CONTINUE
10568       ENDIF
10569
10570       RETURN
10571       END
10572
10573 *$ CREATE DT_COORDI.FOR
10574 *COPY DT_COORDI
10575 *
10576 *===coordi=============================================================*
10577 *
10578       SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10579
10580 ************************************************************************
10581 * Calculation of coordinates of nucleons within nuclei.                *
10582 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10583 *        N / R    number of nucleons / radius of nucleus   (input)     *
10584 * Based on the original version by Shmakov et al.                      *
10585 * This version dated 26.10.95 is revised by S. Roesler                 *
10586 ************************************************************************
10587
10588       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10589       SAVE
10590
10591       PARAMETER ( LINP = 10 ,
10592      &            LOUT = 6 ,
10593      &            LDAT = 9 )
10594
10595       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10596      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10597
10598       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10599
10600       LOGICAL LSTART
10601
10602       PARAMETER (NSRT=10)
10603       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10604       DIMENSION X(3,260),WD(4),RD(3)
10605
10606       DATA PDIF/0.545D0/,R2MIN/0.16D0/
10607       DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10608       DATA RD /2.09D0, 0.935D0, 0.697D0/
10609
10610       X1SUM = ZERO
10611       X2SUM = ZERO
10612       X3SUM = ZERO
10613
10614       IF (N.EQ.1) THEN
10615          X(1,1) = ZERO
10616          X(2,1) = ZERO
10617          X(3,1) = ZERO
10618       ELSEIF (N.EQ.2) THEN
10619          EPS = DT_RNDM(RD(1))
10620          DO 30 I=1,3
10621             IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10622    30    CONTINUE
10623    40    CONTINUE
10624          DO 50 J=1,3
10625             CALL DT_RANNOR(X1,X2)
10626             X(J,1) = RD(I)*X1
10627             X(J,2) = -X(J,1)
10628    50    CONTINUE
10629       ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10630          SIGMA = R/SQRTWO
10631          LSTART = .TRUE.
10632          CALL DT_RANNOR(X3,X4)
10633          DO 100 I=1,N
10634             CALL DT_RANNOR(X1,X2)
10635             X(1,I) = SIGMA*X1
10636             X(2,I) = SIGMA*X2
10637             IF (LSTART) GOTO 80
10638             X(3,I) = SIGMA*X4
10639             CALL DT_RANNOR(X3,X4)
10640             GOTO 90
10641    80       CONTINUE
10642             X(3,I) = SIGMA*X3
10643    90       CONTINUE
10644             LSTART = .NOT.LSTART
10645             X1SUM = X1SUM+X(1,I)
10646             X2SUM = X2SUM+X(2,I)
10647             X3SUM = X3SUM+X(3,I)
10648   100    CONTINUE
10649          X1SUM = X1SUM/DBLE(N)
10650          X2SUM = X2SUM/DBLE(N)
10651          X3SUM = X3SUM/DBLE(N)
10652          DO 101 I=1,N
10653             X(1,I) = X(1,I)-X1SUM
10654             X(2,I) = X(2,I)-X2SUM
10655             X(3,I) = X(3,I)-X3SUM
10656   101    CONTINUE
10657       ELSE
10658
10659 * maximum nuclear radius for coordinate sampling
10660          RMAX = R+4.605D0*PDIF
10661
10662 * initialize pre-sorting
10663          DO 121 I=1,NSRT
10664             ICSRT(I) = 0
10665   121    CONTINUE
10666          DR = TWO*RMAX/DBLE(NSRT)
10667
10668 * sample coordinates for N nucleons
10669          DO 140 I=1,N
10670   120       CONTINUE
10671             RAD = RMAX*(DT_RNDM(DR))**ONETHI
10672             F   = DT_DENSIT(N,RAD,R)
10673             IF (DT_RNDM(RAD).GT.F) GOTO 120
10674 *   theta, phi uniformly distributed
10675             CT  = ONE-TWO*DT_RNDM(F)
10676             ST  = SQRT((ONE-CT)*(ONE+CT))
10677             CALL DT_DSFECF(SFE,CFE)
10678             X(1,I) = RAD*ST*CFE
10679             X(2,I) = RAD*ST*SFE
10680             X(3,I) = RAD*CT
10681 *   ensure that distance between two nucleons is greater than R2MIN
10682             IF (I.LT.2) GOTO 122
10683             I1 = I-1
10684             DO 130 I2=1,I1
10685                DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10686      &                 (X(3,I)-X(3,I2))**2
10687                IF (DIST2.LE.R2MIN) GOTO 120
10688   130       CONTINUE
10689   122       CONTINUE
10690 *   save index according to z-bin
10691             IDXZ        = INT( (X(3,I)+RMAX)/DR )+1
10692             ICSRT(IDXZ) = ICSRT(IDXZ)+1
10693             IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10694             X1SUM = X1SUM+X(1,I)
10695             X2SUM = X2SUM+X(2,I)
10696             X3SUM = X3SUM+X(3,I)
10697   140    CONTINUE
10698          X1SUM = X1SUM/DBLE(N)
10699          X2SUM = X2SUM/DBLE(N)
10700          X3SUM = X3SUM/DBLE(N)
10701          DO 141 I=1,N
10702             X(1,I) = X(1,I)-X1SUM
10703             X(2,I) = X(2,I)-X2SUM
10704             X(3,I) = X(3,I)-X3SUM
10705   141    CONTINUE
10706
10707       ENDIF
10708
10709       RETURN
10710       END
10711
10712 *$ CREATE DT_DENSIT.FOR
10713 *COPY DT_DENSIT
10714 *
10715 *===densit=============================================================*
10716 *
10717       DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10718
10719       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10720       SAVE
10721
10722       PARAMETER ( LINP = 10 ,
10723      &            LOUT = 6 ,
10724      &            LDAT = 9 )
10725
10726       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10727       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10728      &           PI    = TWOPI/TWO)
10729
10730       DIMENSION R0(18),FNORM(18)
10731       DATA R0 /  ZERO,   ZERO,   ZERO,   ZERO, 2.12D0,
10732      &         2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10733      &         2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10734      &         2.72D0, 2.66D0, 2.79D0/
10735       DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10736      &            .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10737      &            .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10738      &            .1214D+01,.1265D+01,.1318D+01/
10739       DATA PDIF /0.545D0/
10740
10741       DT_DENSIT = ZERO
10742 * shell model
10743       IF (NA.LE.4) THEN
10744          STOP 'DT_DENSIT-0'
10745       ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10746          R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10747          DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10748      &            *EXP(-(R/R1)**2)/FNORM(NA)
10749 * Woods-Saxon
10750       ELSEIF (NA.GT.18) THEN
10751          DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10752       ENDIF
10753
10754       RETURN
10755       END
10756
10757 *$ CREATE DT_RNCLUS.FOR
10758 *COPY DT_RNCLUS
10759 *
10760 *===rnclus=============================================================*
10761 *
10762       DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10763
10764 ************************************************************************
10765 * Nuclear radius for nucleus with mass number N.                       *
10766 * This version dated 26.9.00  is written by S. Roesler                 *
10767 ************************************************************************
10768
10769       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10770       SAVE
10771
10772       PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10773
10774 * nucleon radius
10775       PARAMETER (RNUCLE = 1.12D0)
10776
10777 * nuclear radii for selected nuclei
10778       DIMENSION RADNUC(18)
10779       DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10780      &               2.58D0,2.71D0,2.66D0,2.71D0/
10781
10782       IF (N.LE.18) THEN
10783          IF (RADNUC(N).GT.0.0D0) THEN
10784             DT_RNCLUS = RADNUC(N)
10785          ELSE
10786             DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10787          ENDIF
10788       ELSE
10789          DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10790       ENDIF
10791
10792       RETURN
10793       END
10794
10795 *$ CREATE DT_DENTST.FOR
10796 *COPY DT_DENTST
10797 *
10798 *===dentst=============================================================*
10799 *
10800 C      PROGRAM DT_DENTST
10801       SUBROUTINE DT_DENTST
10802
10803       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10804       SAVE
10805
10806       OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10807       OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10808
10809       RMIN  = 0.0D0
10810       RMAX  = 8.0D0
10811       NBINS = 500.0D0
10812       DR    = (RMAX-RMIN)/DBLE(NBINS)
10813       DO 1 IA=5,18
10814          FMAX = 0.0D0
10815          DO 2 IR=1,NBINS+1
10816             R = RMIN+DBLE(IR-1)*DR
10817             F = DT_DENSIT(IA,R,R)
10818             IF (F.GT.FMAX) FMAX = F
10819             WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10820     2    CONTINUE
10821          WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10822     1 CONTINUE
10823
10824       CLOSE(40)
10825       CLOSE(41)
10826
10827       END
10828
10829 *$ CREATE DT_SHMAKI.FOR
10830 *COPY DT_SHMAKI
10831 *
10832 *===shmaki=============================================================*
10833 *
10834       SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10835
10836 ************************************************************************
10837 * Initialisation of Glauber formalism. This subroutine has to be       *
10838 * called once (in case of target emulsions as often as many different  *
10839 * target nuclei are considered) before events are sampled.             *
10840 *         NA / NCA   mass number/charge of projectile nucleus          *
10841 *         NB / NCB   mass number/charge of target     nucleus          *
10842 *         IJP        identity of projectile (hadrons/leptons/photons)  *
10843 *         PPN        projectile momentum (for projectile nuclei:       *
10844 *                    momentum per nucleon) in target rest system       *
10845 *         MODE = 0   Glauber formalism invoked                         *
10846 *              = 1   fitted results are loaded from data-file          *
10847 *              = 99  NTARG is forced to be 1                           *
10848 *                    (used in connection with GLAUBERI-card only)      *
10849 * This version dated 22.03.96 is based on the original SHMAKI-routine  *
10850 * and revised by S. Roesler.                                           *
10851 ************************************************************************
10852
10853       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10854       SAVE
10855
10856       PARAMETER ( LINP = 10 ,
10857      &            LOUT = 6 ,
10858      &            LDAT = 9 )
10859
10860       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10861      &           THREE=3.0D0)
10862
10863       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10864
10865 * Glauber formalism: parameters
10866       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10867      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10868      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10869      &                NSITEB,NSTATB
10870
10871 * Lorentz-parameters of the current interaction
10872       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10873      &                UMO,PPCM,EPROJ,PPROJ
10874
10875 * properties of photon/lepton projectiles
10876       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10877
10878 * kinematical cuts for lepton-nucleus interactions
10879       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10880      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10881
10882 * Glauber formalism: cross sections
10883       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10884      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10885      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10886      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10887      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10888      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10889      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10890      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10891      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10892      &                BSLOPE,NEBINI,NQBINI
10893
10894 * cuts for variable energy runs
10895       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10896
10897 * nucleon-nucleon event-generator
10898       CHARACTER*8 CMODEL
10899       LOGICAL LPHOIN
10900       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10901
10902 * Glauber formalism: flags and parameters for statistics
10903       LOGICAL LPROD
10904       CHARACTER*8 CGLB
10905       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10906
10907       DATA NTARG,ICOUT,IVEOUT /0,0,0/
10908
10909 C     CALL DT_HISHAD
10910 C     STOP
10911
10912       NTARG = NTARG+1
10913       IF (MODE.EQ.99) NTARG = 1
10914       NIDX = -NTARG
10915       IF (MODE.EQ.-1) NIDX = NTARG
10916
10917       IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10918       IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10919  1000    FORMAT(//,1X,'SHMAKI:    Glauber formalism (Shmakov et. al) -',
10920      &          ' initialization',/,12X,'--------------------------',
10921      &          '-------------------------',/)
10922
10923       IF (MODE.EQ.2) THEN
10924          CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10925          CALL DT_SHFAST(MODE,PPN,IBACK)
10926          STOP ' Glauber pre-initialization done'
10927       ENDIF
10928       IF (MODE.EQ.1) THEN
10929          CALL DT_PROFBI(NA,NB,PPN,NTARG)
10930       ELSE
10931          IBACK = 1
10932          IF (MODE.EQ.3)  CALL DT_SHFAST(MODE,PPN,IBACK)
10933          IF (IBACK.EQ.1) THEN
10934 * lepton-nucleus (variable energy runs)
10935             IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10936      &          (IJP.EQ.10).OR.(IJP.EQ.11))   THEN
10937                IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10938      &            WRITE(LOUT,1002) NB,NCB
10939  1002          FORMAT(1X,'variable energy run:     projectile-id:  7',
10940      &                '    target A/Z: ',I3,' /',I3,/,/,8X,
10941      &                'E_cm (GeV)    Q^2 (GeV^2)',
10942      &                '    Sigma_tot (mb)     Sigma_in (mb)',/,7X,
10943      &                '--------------------------------',
10944      &                '------------------------------')
10945                AECMLO = LOG10(MIN(UMO,ECMLI))
10946                AECMHI = LOG10(MIN(UMO,ECMHI))
10947                IESTEP = NEB-1
10948                DAECM  = (AECMHI-AECMLO)/DBLE(IESTEP)
10949                IF (AECMLO.EQ.AECMHI) IESTEP = 0
10950                DO 1 I=1,IESTEP+1
10951                   ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10952                   IF (Q2HI.GT.0.1D0) THEN
10953                      IF (Q2LI.LT.0.01D0) THEN
10954                         CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10955                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10956      &                     WRITE(LOUT,1003)
10957      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10958                         Q2LI = 0.01D0
10959                         IBIN = 2
10960                      ELSE
10961                         IBIN = 1
10962                      ENDIF
10963                      IQSTEP = NQB-IBIN
10964                      AQ2LO  = LOG10(Q2LI)
10965                      AQ2HI  = LOG10(Q2HI)
10966                      DAQ2   = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10967                      DO 2 J=IBIN,IQSTEP+IBIN
10968                         Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10969                         CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10970                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10971      &                     WRITE(LOUT,1003) ECMNN(I),
10972      &                     Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10973     2                CONTINUE
10974                   ELSE
10975                      CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10976                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10977      &                  WRITE(LOUT,1003)
10978      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10979                   ENDIF
10980  1003             FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10981     1          CONTINUE
10982                IVEOUT = 1
10983             ELSE
10984 * hadron/photon/nucleus-nucleus
10985                IF ((ABS(VAREHI).GT.ZERO).AND.
10986      &             (ABS(VAREHI).GT.ABS(VARELO))) THEN
10987                   IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10988                      WRITE(LOUT,1004) NA,NB,NCB
10989  1004                FORMAT(1X,'variable energy run:    projectile-id:',
10990      &                      I3,'    target A/Z: ',I3,' /',I3,/)
10991                      WRITE(LOUT,1005)
10992  1005                FORMAT('  E_cm (GeV)  E_Lab (GeV)  sig_tot^pp (mb)'
10993      &                      ,'  Sigma_tot (mb)  Sigma_prod (mb)',/,
10994      &                      ' -------------------------------------',
10995      &                      '--------------------------------------')
10996                   ENDIF
10997                   AECMLO = LOG10(VARCLO)
10998                   AECMHI = LOG10(VARCHI)
10999                   IESTEP = NEB-1
11000                   DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
11001                   IF (AECMLO.EQ.AECMHI) IESTEP = 0
11002                   DO 3 I=1,IESTEP+1
11003                      ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
11004                      AMP = 0.938D0
11005                      AMT = 0.938D0
11006                      AMP2 = AMP**2
11007                      AMT2 = AMT**2
11008                      ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
11009                      PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
11010                      CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
11011                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
11012      &                 WRITE(LOUT,1006)
11013      &                 ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
11014  1006             FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
11015     3             CONTINUE
11016                   IVEOUT = 1
11017                ELSE
11018                   CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
11019                ENDIF
11020             ENDIF
11021          ENDIF
11022       ENDIF
11023
11024       IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
11025      &    (IOGLB.NE.100)) THEN
11026          WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
11027      &                    BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
11028  1001    FORMAT(38X,'projectile',
11029      &          '      target',/,1X,'Mass number / charge',
11030      &          17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
11031      &          'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
11032      &          'Parameters of elastic scattering amplitude:',/,5X,
11033      &          'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
11034      &          F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
11035      &          'statistics at each b-step',4X,I5,/,/,1X,
11036      &          'Prod. cross section  ',5X,F10.4,' mb',/)
11037       ENDIF
11038
11039       RETURN
11040       END
11041
11042 *$ CREATE DT_PROFBI.FOR
11043 *COPY DT_PROFBI
11044 *
11045 *===profbi=============================================================*
11046 *
11047       SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
11048
11049 ************************************************************************
11050 * Integral over profile function (to be used for impact-parameter      *
11051 * sampling during event generation).                                   *
11052 * Fitted results are used.                                             *
11053 *         NA / NB    mass numbers of proj./target nuclei               *
11054 *         PPN        projectile momentum (for projectile nuclei:       *
11055 *                    momentum per nucleon) in target rest system       *
11056 *         NTARG      index of target material (i.e. kind of nucleus)   *
11057 * This version dated 31.05.95 is revised by S. Roesler                 *
11058 ************************************************************************
11059
11060       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11061       SAVE
11062
11063       PARAMETER ( LINP = 10 ,
11064      &            LOUT = 6 ,
11065      &            LDAT = 9 )
11066
11067       SAVE
11068
11069       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
11070
11071       LOGICAL LSTART
11072       CHARACTER CNAME*80
11073
11074       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11075
11076 * Glauber formalism: parameters
11077       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11078      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11079      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11080      &                NSITEB,NSTATB
11081
11082 * Glauber formalism: cross sections
11083       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11084      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11085      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11086      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11087      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11088      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11089      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11090      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11091      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11092      &                BSLOPE,NEBINI,NQBINI
11093
11094       PARAMETER (NGLMAX=8000)
11095       DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
11096      &          GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
11097
11098       DATA LSTART /.TRUE./
11099
11100       IF (LSTART) THEN
11101 * read fit-parameters from file
11102          OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
11103          I = 0
11104     1    CONTINUE
11105          READ(47,'(A80)') CNAME
11106          IF (CNAME.EQ.'STOP') GOTO 2
11107          I = I+1
11108          READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
11109      &                 GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
11110      &                 GLAFIT(4,I),GLAFIT(5,I)
11111          IF (I+1.GT.NGLMAX) THEN
11112             WRITE(LOUT,1000)
11113  1000       FORMAT(1X,'PROFBI:    warning! array size exceeded - ',
11114      &             'program stopped')
11115             STOP
11116          ENDIF
11117          GOTO 1
11118     2    CONTINUE
11119          NGLPAR = I
11120          LSTART = .FALSE.
11121       ENDIF
11122
11123       NNA = NA
11124       NNB = NB
11125       IF (NA.GT.NB) THEN
11126          NNA = NB
11127          NNB = NA
11128       ENDIF
11129       IDXGLA = 0
11130       DO 3 J=1,NGLPAR
11131          IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
11132             IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
11133             DO 4 K=1,J-1
11134                IPOINT = J-K
11135                IF (J.EQ.NGLPAR) IPOINT = J+1-K
11136                IF ((NNA.GT.NGLIP(IPOINT)).OR.
11137      &             (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
11138                   IF (IPOINT.EQ.1) IPOINT = 0
11139                   NATMP = NGLIP(IPOINT+1)
11140                   IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
11141                      IDXGLA = IPOINT+1
11142                      GOTO 6
11143                   ELSE
11144                      J1BEG = IPOINT+1
11145                      J1END = J
11146 C                    IF (J.EQ.NGLPAR) THEN
11147 C                       J1BEG = IPOINT
11148 C                       J1END = J
11149 C                    ENDIF
11150                      DO 5 J1=J1BEG,J1END
11151                         IF (NGLIP(J1).EQ.NATMP) THEN
11152                            IF (PPN.LT.GLAPPN(J1)) THEN
11153                               IDXGLA = J1
11154                               GOTO 6
11155                            ENDIF
11156                         ELSE
11157                            IDXGLA = J1-1
11158                            GOTO 6
11159                         ENDIF
11160     5                CONTINUE
11161                      IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
11162      &                  IDXGLA = NGLPAR
11163                   ENDIF
11164                ENDIF
11165     4       CONTINUE
11166          ENDIF
11167     3 CONTINUE
11168
11169     6 CONTINUE
11170       IF (IDXGLA.EQ.0) THEN
11171          WRITE(LOUT,1001) NNA,NNB,PPN
11172  1001    FORMAT(1X,'PROFBI:   configuration (NA,NB,PPN = ',
11173      &          2I4,F6.0,') not found ')
11174          STOP
11175       ENDIF
11176
11177 * no interpolation yet available
11178       XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
11179
11180       BSITE(1,1,NTARG,1) = ZERO
11181       DO 10 I=2,NSITEB
11182          XX = DBLE(I)
11183          POLY  = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
11184      &           GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
11185      &           GLAFIT(5,IDXGLA)*XX**4
11186          IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
11187          BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
11188          IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
11189    10 CONTINUE
11190
11191       RETURN
11192       END
11193
11194 *$ CREATE DT_GLAUBE.FOR
11195 *COPY DT_GLAUBE
11196 *
11197 *===glaube=============================================================*
11198 *
11199       SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
11200
11201 ************************************************************************
11202 * Calculation of configuartion of interacting nucleons for one event.  *
11203 *    NB / NB    mass numbers of proj./target nuclei           (input)  *
11204 *    B          impact parameter                              (output) *
11205 *    INTT       total number of wounded nucleons                 "     *
11206 *    INTA / INTB number of wounded nucleons in proj. / target    "     *
11207 *    JS / JT(i) number of collisions proj. / target nucleon i is       *
11208 *                                                   involved  (output) *
11209 *    NIDX       index of projectile/target material            (input) *
11210 *               = -2 call within FLUKA transport calculation           *
11211 * This is an update of the original routine SHMAKO by J.Ranft/HJM      *
11212 * This version dated 22.03.96 is revised by S. Roesler                 *
11213 *                                                                      *
11214 * Last change 27.12.2006 by S. Roesler.                                *
11215 ************************************************************************
11216
11217       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11218       SAVE
11219
11220       PARAMETER ( LINP = 10 ,
11221      &            LOUT = 6 ,
11222      &            LDAT = 9 )
11223
11224       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
11225      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
11226
11227       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11228
11229       PARAMETER ( MAXNCL = 260,
11230
11231      &            MAXVQU = MAXNCL,
11232      &            MAXSQU = 20*MAXVQU,
11233      &            MAXINT = MAXVQU+MAXSQU)
11234
11235 * Glauber formalism: parameters
11236       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11237      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11238      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11239      &                NSITEB,NSTATB
11240
11241 * Glauber formalism: cross sections
11242       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11243      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11244      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11245      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11246      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11247      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11248      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11249      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11250      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11251      &                BSLOPE,NEBINI,NQBINI
11252
11253 * Lorentz-parameters of the current interaction
11254       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
11255      &                UMO,PPCM,EPROJ,PPROJ
11256
11257 * properties of photon/lepton projectiles
11258       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
11259
11260 * Glauber formalism: collision properties
11261       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
11262      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
11263      &                NCP,NCT
11264 * Glauber formalism: flags and parameters for statistics
11265       LOGICAL LPROD
11266       CHARACTER*8 CGLB
11267       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11268
11269       DIMENSION JS(MAXNCL),JT(MAXNCL)
11270
11271       NTARG = ABS(NIDX)
11272
11273 * get actual energy from /DTLTRA/
11274       ECMNOW = UMO
11275       Q2     = VIRT
11276 *
11277 * new patch for pre-initialized variable projectile/target/energy runs,
11278 * bypassed for use within FLUKA (Nidx=-2)
11279       IF (IOGLB.EQ.100) THEN
11280          IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
11281 *
11282 * variable energy run, interpolate profile function
11283       ELSE
11284          I1   = 1
11285          I2   = 1
11286          RATE = ONE
11287          IF (NEBINI.GT.1) THEN
11288             IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
11289                I1   = NEBINI
11290                I2   = NEBINI
11291                RATE = ONE
11292             ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
11293                DO 1 I=2,NEBINI
11294                   IF (ECMNOW.LT.ECMNN(I)) THEN
11295                      I1   = I-1
11296                      I2   = I
11297                      RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
11298                      GOTO 2
11299                   ENDIF
11300     1          CONTINUE
11301     2          CONTINUE
11302             ENDIF
11303          ENDIF
11304          J1   = 1
11305          J2   = 1
11306          RATQ = ONE
11307          IF (NQBINI.GT.1) THEN
11308             IF (Q2.GE.Q2G(NQBINI)) THEN
11309                J1   = NQBINI
11310                J2   = NQBINI
11311                RATQ = ONE
11312             ELSEIF (Q2.GT.Q2G(1)) THEN
11313                DO 3 I=2,NQBINI
11314                   IF (Q2.LT.Q2G(I)) THEN
11315                      J1   = I-1
11316                      J2   = I
11317                      RATQ = LOG10(     Q2/MAX(Q2G(J1),TINY14))/
11318      &                      LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11319 C                    RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
11320                      GOTO 4
11321                   ENDIF
11322     3          CONTINUE
11323     4          CONTINUE
11324             ENDIF
11325          ENDIF
11326
11327          DO 5 I=1,KSITEB
11328             BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
11329      &         RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11330      &         RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11331      &         RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
11332      &                    BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
11333     5    CONTINUE
11334       ENDIF
11335
11336       CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
11337       IF (NIDX.LE.-1) THEN
11338          RPROJ = RASH(1)
11339          RTARG = RBSH(NTARG)
11340       ELSE
11341          RPROJ = RASH(NTARG)
11342          RTARG = RBSH(1)
11343       ENDIF
11344
11345       RETURN
11346       END
11347
11348 *$ CREATE DT_DIAGR.FOR
11349 *COPY DT_DIAGR
11350 *
11351 *===diagr==============================================================*
11352 *
11353       SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
11354      &                                                         NIDX)
11355
11356 ************************************************************************
11357 * Based on the original version by Shmakov et al.                      *
11358 * This version dated 21.04.95 is revised by S. Roesler                 *
11359 ************************************************************************
11360
11361       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11362       SAVE
11363
11364       PARAMETER ( LINP = 10 ,
11365      &            LOUT = 6 ,
11366      &            LDAT = 9 )
11367
11368       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
11369       PARAMETER (TWOPI  = 6.283185307179586454D+00,
11370      &           PI     = TWOPI/TWO,
11371      &           GEV2MB = 0.38938D0,
11372      &           GEV2FM = 0.1972D0,
11373      &           ALPHEM = ONE/137.0D0,
11374 * proton mass
11375      &           AMP    = 0.938D0,
11376      &           AMP2   = AMP**2,
11377 * rho0 mass
11378      &           AMRHO0 = 0.77D0)
11379
11380       COMPLEX*16 C,CA,CI
11381
11382       PARAMETER ( MAXNCL = 260,
11383
11384      &            MAXVQU = MAXNCL,
11385      &            MAXSQU = 20*MAXVQU,
11386      &            MAXINT = MAXVQU+MAXSQU)
11387
11388 * particle properties (BAMJET index convention)
11389       CHARACTER*8  ANAME
11390       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11391      &                IICH(210),IIBAR(210),K1(210),K2(210)
11392
11393       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11394
11395 * emulsion treatment
11396       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11397      &                NCOMPO,IEMUL
11398
11399 * Glauber formalism: parameters
11400       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11401      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11402      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11403      &                NSITEB,NSTATB
11404
11405 * Glauber formalism: cross sections
11406       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11407      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11408      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11409      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11410      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11411      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11412      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11413      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11414      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11415      &                BSLOPE,NEBINI,NQBINI
11416
11417 * VDM parameter for photon-nucleus interactions
11418       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11419
11420 * nucleon-nucleon event-generator
11421       CHARACTER*8 CMODEL
11422       LOGICAL LPHOIN
11423       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
11424 **PHOJET105a
11425 C     COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11426 **PHOJET112
11427
11428 C  obsolete cut-off information
11429       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
11430       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11431 **
11432
11433 * coordinates of nucleons
11434       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
11435
11436 * interface between Glauber formalism and DPM
11437       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
11438      &                INTER1(MAXINT),INTER2(MAXINT)
11439
11440 * statistics: Glauber-formalism
11441       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
11442
11443 * n-n cross section fluctuations
11444       PARAMETER (NBINS = 1000)
11445       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
11446
11447       DIMENSION JS(MAXNCL),JT(MAXNCL),
11448      &          JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
11449      &          JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
11450       DIMENSION NWA(0:210),NWB(0:210)
11451
11452       LOGICAL LFIRST
11453       DATA LFIRST /.TRUE./
11454
11455       DATA NTARGO,ICNT /0,0/
11456
11457       NTARG = ABS(NIDX)
11458
11459       IF (LFIRST) THEN
11460          LFIRST = .FALSE.
11461          IF (NCOMPO.EQ.0) THEN
11462             NCALL  = 0
11463             NWAMAX = NA
11464             NWBMAX = NB
11465             DO 17 I=0,210
11466                NWA(I) = 0
11467                NWB(I) = 0
11468    17       CONTINUE
11469          ENDIF
11470       ENDIF
11471       IF (NTARG.EQ.-1) THEN
11472          IF (NCOMPO.EQ.0) THEN
11473             WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
11474             WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
11475      &                                NCALL,NWAMAX,NWBMAX
11476             DO 18 I=1,MAX(NWAMAX,NWBMAX)
11477                WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
11478      &                          I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
11479      &                            NWB(I),DBLE(NWB(I))/DBLE(NCALL)
11480    18       CONTINUE
11481          ENDIF
11482          RETURN
11483       ENDIF
11484
11485       DCOH   = 1.0D10
11486       IPNT   = 0
11487
11488       SQ2  = Q2
11489       IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
11490       S   = ECMNOW**2
11491       X   = SQ2/(S+SQ2-AMP2)
11492       XNU = (S+SQ2-AMP2)/(TWO*AMP)
11493 * photon projectiles: recalculate photon-nucleon amplitude
11494       IF (IJPROJ.EQ.7) THEN
11495    15    CONTINUE
11496 *  VDM assumption: mass of V-meson
11497          AMV2   = DT_SAM2(SQ2,ECMNOW)
11498          AMV    = SQRT(AMV2)
11499          IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
11500 *  check for pointlike interaction
11501          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
11502 **sr 27.10.
11503 C        SIGSH  = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11504          SIGSH  = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11505 **
11506          ROSH   = 0.1D0
11507          BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
11508      &                   +0.25D0*LOG(S/(AMV2+SQ2)))
11509 *  coherence length
11510          IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
11511       ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
11512          IF (MCGENE.EQ.2) THEN
11513             ZERO1 = ZERO
11514             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
11515      &                                                BSLOPE,0)
11516          ELSE
11517             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
11518          ENDIF
11519          IF (ECMNOW.LE.3.0D0) THEN
11520             ROSH = -0.43D0
11521          ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
11522             ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
11523          ELSEIF (ECMNOW.GT.50.0D0) THEN
11524             ROSH = 0.1D0
11525          ENDIF
11526          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11527          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11528          IF (MCGENE.EQ.2) THEN
11529             ZERO1 = ZERO
11530             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
11531      &                                                  BDUM,0)
11532             SIGSH = SIGSH/10.0D0
11533          ELSE
11534 C           SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11535             DUMZER = ZERO
11536             CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11537             SIGSH = SIGSH/10.0D0
11538          ENDIF
11539       ELSE
11540          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
11541          ROSH   = 0.01D0
11542          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11543          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11544 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11545          DUMZER = ZERO
11546          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11547          SIGSH = SIGSH/10.0D0
11548       ENDIF
11549       GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
11550       GAM = GSH
11551       RCA = GAM*SIGSH/TWOPI
11552       FCA = -ROSH*RCA
11553       CA  = DCMPLX(RCA,FCA)
11554       CI  = DCMPLX(ONE,ZERO)
11555
11556    16 CONTINUE
11557 * impact parameter
11558       IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11559
11560       NTRY = 0
11561     3 CONTINUE
11562       NTRY = NTRY+1
11563 * initializations
11564       JNT  = 0
11565       DO 1 I=1,NA
11566          JS(I) = 0
11567     1 CONTINUE
11568       DO 2 I=1,NB
11569          JT(I) = 0
11570     2 CONTINUE
11571       IF (IJPROJ.EQ.7) THEN
11572          DO 8 I=1,MAXNCL
11573             JS0(I) = 0
11574             JNT0(I)= 0
11575             DO 9 J=1,NB
11576                JT0(I,J) = 0
11577     9       CONTINUE
11578     8    CONTINUE
11579       ENDIF
11580
11581 * nucleon configuration
11582 C     IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11583       IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11584 C        CALL DT_CONUCL(PKOO,NA,RASH,2)
11585 C        CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11586          IF (NIDX.LE.-1) THEN
11587             CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11588             CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11589          ELSE
11590             CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11591             CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11592          ENDIF
11593          NTARGO = NTARG
11594       ENDIF
11595       ICNT = ICNT+1
11596
11597 * LEPTO: pick out one struck nucleon
11598       IF (MCGENE.EQ.3) THEN
11599          JNT     = 1
11600          JS(1)   = 1
11601          IDX     = INT(DT_RNDM(X)*NB)+1
11602          JT(IDX) = 1
11603          B       = ZERO
11604          GOTO 19
11605       ENDIF
11606
11607       DO 4 INA=1,NA
11608 * cross section fluctuations
11609          AFLUC = ONE
11610          IF (IFLUCT.EQ.1) THEN
11611             IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11612             AFLUC = FLUIXX(IFLUK)
11613          ENDIF
11614          KK1  = 1
11615          KINT = 1
11616          DO 5 INB=1,NB
11617 * photon-projectile: check for supression by coherence length
11618             IF (IJPROJ.EQ.7) THEN
11619                IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11620                   KK1  = INB
11621                   KINT = KINT+1
11622                ENDIF
11623             ENDIF
11624             QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11625             QQ2 =   TKOO(2,INB)-PKOO(2,INA)
11626             XY  = GAM*(QQ1*QQ1+QQ2*QQ2)
11627             IF (XY.LE.15.0D0) THEN
11628                C  = CI-CA*AFLUC*EXP(-XY)
11629                AR = DBLE(C)
11630                AI = DIMAG(C)
11631                P  = AR*AR+AI*AI
11632                IF (DT_RNDM(XY).GE.P) THEN
11633                   JNT = JNT+1
11634                   IF (IJPROJ.EQ.7) THEN
11635                      JNT0(KINT) = JNT0(KINT)+1
11636                      IF (JNT0(KINT).GT.MAXNCL) THEN
11637                         WRITE(LOUT,1001) MAXNCL
11638  1001                   FORMAT(1X,
11639      &                        'DIAGR:  no. of requested interactions',
11640      &                        ' exceeds array dimensions ',I4)
11641                         STOP
11642                      ENDIF
11643                      JS0(KINT)      = JS0(KINT)+1
11644                      JT0(KINT,INB)  = JT0(KINT,INB)+1
11645                      JI1(KINT,JNT0(KINT)) = INA
11646                      JI2(KINT,JNT0(KINT)) = INB
11647                   ELSE
11648                      IF (JNT.GT.MAXINT) THEN
11649                         WRITE(LOUT,1000) JNT, MAXINT
11650  1000                   FORMAT(1X,
11651      &                        'DIAGR:  no. of requested interactions ('
11652      &                        ,I4,') exceeds array dimensions (',I4,')')
11653                         STOP
11654                      ENDIF
11655                      JS(INA) = JS(INA)+1
11656                      JT(INB) = JT(INB)+1
11657                      INTER1(JNT) = INA
11658                      INTER2(JNT) = INB
11659                   ENDIF
11660                ENDIF
11661             ENDIF
11662     5    CONTINUE
11663     4 CONTINUE
11664
11665       IF (JNT.EQ.0) THEN
11666          IF (NTRY.LT.500) THEN
11667             GOTO 3
11668          ELSE
11669 C           WRITE(6,*) ' new impact parameter required (old= ',B,')'
11670             GOTO 16
11671          ENDIF
11672       ENDIF
11673
11674       IDIREC = 0
11675       IF (IJPROJ.EQ.7) THEN
11676          K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11677    10    CONTINUE
11678          IF (JNT0(K).EQ.0) THEN
11679             K = K+1
11680             IF (K.GT.KINT) K = 1
11681             GOTO 10
11682          ENDIF
11683 * supress Glauber-cascade by direct photon processes
11684          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11685          IF (IPNT.GT.0) THEN
11686             JNT   = 1
11687             JS(1) = 1
11688             DO 11 INB=1,NB
11689                JT(INB) = JT0(K,INB)
11690                IF (JT(INB).GT.0) GOTO 12
11691    11       CONTINUE
11692    12       CONTINUE
11693             INTER1(1) = 1
11694             INTER2(1) = INB
11695             IDIREC    = IPNT
11696          ELSE
11697             JNT   = JNT0(K)
11698             JS(1) = JS0(K)
11699             DO 13 INB=1,NB
11700                JT(INB) = JT0(K,INB)
11701    13       CONTINUE
11702             DO 14 I=1,JNT
11703                INTER1(I) = JI1(K,I)
11704                INTER2(I) = JI2(K,I)
11705    14       CONTINUE
11706          ENDIF
11707       ENDIF
11708
11709    19 CONTINUE
11710       INTA = 0
11711       INTB = 0
11712       DO 6 I=1,NA
11713         IF (JS(I).NE.0) INTA=INTA+1
11714     6 CONTINUE
11715       DO 7 I=1,NB
11716         IF (JT(I).NE.0) INTB=INTB+1
11717     7 CONTINUE
11718       ICWPG = INTA
11719       ICWTG = INTB
11720       ICIG  = JNT
11721       IPGLB = IPGLB+INTA
11722       ITGLB = ITGLB+INTB
11723       NGLB = NGLB+1
11724
11725       IF (NCOMPO.EQ.0) THEN
11726          NCALL = NCALL+1
11727          NWA(INTA) = NWA(INTA)+1
11728          NWB(INTB) = NWB(INTB)+1
11729       ENDIF
11730
11731       RETURN
11732       END
11733
11734 *$ CREATE DT_MODB.FOR
11735 *COPY DT_MODB
11736 *
11737 *===modb===============================================================*
11738 *
11739       SUBROUTINE DT_MODB(B,NIDX)
11740
11741 ************************************************************************
11742 * Sampling of impact parameter of collision.                           *
11743 *    B          impact parameter    (output)                           *
11744 *    NIDX       index of projectile/target material             (input)*
11745 * Based on the original version by Shmakov et al.                      *
11746 * This version dated 21.04.95 is revised by S. Roesler                 *
11747 *                                                                      *
11748 * Last change 27.12.2006 by S. Roesler.                                *
11749 ************************************************************************
11750
11751       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11752       SAVE
11753
11754       PARAMETER ( LINP = 10 ,
11755      &            LOUT = 6 ,
11756      &            LDAT = 9 )
11757
11758       PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11759
11760       LOGICAL LEFT,LFIRST
11761
11762 * central particle production, impact parameter biasing
11763       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11764
11765       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11766
11767 * Glauber formalism: parameters
11768       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11769      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11770      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11771      &                NSITEB,NSTATB
11772
11773 * Glauber formalism: cross sections
11774       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11775      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11776      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11777      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11778      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11779      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11780      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11781      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11782      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11783      &                BSLOPE,NEBINI,NQBINI
11784
11785       DATA LFIRST /.TRUE./
11786
11787       NTARG = ABS(NIDX)
11788       IF (NIDX.LE.-1) THEN
11789          RA = RASH(1)
11790          RB = RBSH(NTARG)
11791       ELSE
11792          RA = RASH(NTARG)
11793          RB = RBSH(1)
11794       ENDIF
11795
11796       IF (ICENTR.EQ.2) THEN
11797          IF (RA.EQ.RB) THEN
11798             BB = DT_RNDM(B)*(0.3D0*RA)**2
11799             B  = SQRT(BB)
11800          ELSEIF(RA.LT.RB)THEN
11801             BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11802             B  = SQRT(BB)
11803          ELSEIF(RA.GT.RB)THEN
11804             BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11805             B  = SQRT(BB)
11806          ENDIF
11807       ELSE
11808     9    CONTINUE
11809          Y  = DT_RNDM(BB)
11810          I0 = 1
11811          I2 = NSITEB
11812    10    CONTINUE
11813          I1 = (I0+I2)/2
11814          LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11815      &          *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11816          IF (LEFT) GOTO 20
11817          I0 = I1
11818          GOTO 30
11819    20    CONTINUE
11820          I2 = I1
11821    30    CONTINUE
11822          IF (I2-I0-2) 40,50,60
11823    40    CONTINUE
11824          I1 = I2+1
11825          IF (I1.GT.NSITEB) I1 = I0-1
11826          GOTO 70
11827    50    CONTINUE
11828          I1 = I0+1
11829          GOTO 70
11830    60    CONTINUE
11831          GOTO 10
11832    70    CONTINUE
11833          X0 = DBLE(I0-1)*BSTEP(NTARG)
11834          X1 = DBLE(I1-1)*BSTEP(NTARG)
11835          X2 = DBLE(I2-1)*BSTEP(NTARG)
11836          Y0 = BSITE(0,1,NTARG,I0)
11837          Y1 = BSITE(0,1,NTARG,I1)
11838          Y2 = BSITE(0,1,NTARG,I2)
11839    80    CONTINUE
11840          B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11841      &       X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11842      &       X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11843 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11844          B = B+0.5D0*BSTEP(NTARG)
11845          IF (B.LT.ZERO) B = X1
11846          IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11847          IF (ICENTR.LT.0) THEN
11848             IF (LFIRST) THEN
11849                LFIRST = .FALSE.
11850                IF (ICENTR.LE.-100) THEN
11851                   BIMIN  = 0.0D0
11852                ELSE
11853                   XSFRAC = 0.0D0
11854                ENDIF
11855                CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11856                WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11857      &                          BIMIN,BIMAX,XSFRAC*100.0D0,
11858      &                          XSFRAC*XSPRO(1,1,NTARG)
11859  10000         FORMAT(/,1X,'DT_MODB:      Biasing in impact parameter',
11860      &                /,15X,'---------------------------'/,/,4X,
11861      &                'average radii of proj / targ :',F10.3,' fm /',
11862      &                F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11863      &                F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11864      &                F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11865      &                ' cross section :',F10.3,' %',/,5X,
11866      &                'corresponding cross section :',F10.3,' mb',/)
11867             ENDIF
11868             IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11869                B = BIMIN
11870             ELSE
11871                IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11872             ENDIF
11873          ENDIF
11874       ENDIF
11875
11876       RETURN
11877       END
11878
11879 *$ CREATE DT_SHFAST.FOR
11880 *COPY DT_SHFAST
11881 *
11882 *===shfast=============================================================*
11883 *
11884       SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11885
11886       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11887       SAVE
11888
11889       PARAMETER ( LINP = 10 ,
11890      &            LOUT = 6 ,
11891      &            LDAT = 9 )
11892
11893       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11894      &           ONE=1.0D0,TWO=2.0D0)
11895
11896       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11897
11898 * Glauber formalism: parameters
11899       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11900      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11901      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11902      &                NSITEB,NSTATB
11903
11904 * properties of interacting particles
11905       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11906
11907 * Glauber formalism: cross sections
11908       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11909      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11910      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11911      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11912      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11913      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11914      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11915      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11916      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11917      &                BSLOPE,NEBINI,NQBINI
11918
11919       IBACK = 0
11920
11921       IF (MODE.EQ.2) THEN
11922          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11923          WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11924  1000    FORMAT(1X,8I5,E15.5)
11925          WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11926  1001    FORMAT(1X,4E15.5)
11927          WRITE(47,1002) SIGSH,ROSH,GSH
11928  1002    FORMAT(1X,3E15.5)
11929          DO 10 I=1,100
11930             WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11931    10    CONTINUE
11932          WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11933  1003    FORMAT(1X,2I10,3E15.5)
11934          CLOSE(47)
11935       ELSE
11936          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11937          READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11938          IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11939      &       (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11940      &       .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11941      &       (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11942             READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11943             READ(47,1002) SIGSH,ROSH,GSH
11944             DO 11 I=1,100
11945                READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11946    11       CONTINUE
11947             READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11948          ELSE
11949             IBACK = 1
11950          ENDIF
11951          CLOSE(47)
11952       ENDIF
11953
11954       RETURN
11955       END
11956
11957 *$ CREATE DT_POILIK.FOR
11958 *COPY DT_POILIK
11959 *
11960 *===poilik=============================================================*
11961 *
11962       SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11963
11964       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11965       SAVE
11966
11967       PARAMETER ( LINP = 10 ,
11968      &            LOUT = 6 ,
11969      &            LDAT = 9 )
11970
11971       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11972       PARAMETER (NE = 8)
11973
11974 **PHOJET105a
11975 C     CHARACTER*8 MDLNA
11976 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11977 C     PARAMETER (IEETAB=10)
11978 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11979 **PHOJET110
11980
11981 C  model switches and parameters
11982       CHARACTER*8 MDLNA
11983       INTEGER ISWMDL,IPAMDL
11984       DOUBLE PRECISION PARMDL
11985       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11986
11987 C  energy-interpolation table
11988       INTEGER IEETA2
11989       PARAMETER ( IEETA2 = 20 )
11990       INTEGER ISIMAX
11991       DOUBLE PRECISION SIGTAB,SIGECM
11992       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11993 **
11994
11995 * VDM parameter for photon-nucleus interactions
11996       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11997 **sr 22.7.97
11998
11999       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12000
12001 * Glauber formalism: cross sections
12002       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
12003      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
12004      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
12005      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
12006      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
12007      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12008      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12009      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12010      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12011      &                BSLOPE,NEBINI,NQBINI
12012 **
12013
12014       DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
12015
12016       IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
12017
12018 * load cross sections from interpolation table
12019       IP = 1
12020       IF(ECM.LE.SIGECM(IP,1)) THEN
12021         I1 = 1
12022         I2 = 1
12023       ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
12024         DO 50 I=2,ISIMAX
12025           IF(ECM.LE.SIGECM(IP,I)) GOTO 200
12026   50    CONTINUE
12027  200    CONTINUE
12028         I1 = I-1
12029         I2 = I
12030       ELSE
12031         WRITE(LOUT,'(/1X,A,2E12.3)')
12032      &    'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
12033         I1 = ISIMAX
12034         I2 = ISIMAX
12035       ENDIF
12036       FAC2 = ZERO
12037       IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
12038      &                     /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
12039       FAC1 = ONE-FAC2
12040
12041       SIGANO = DT_SANO(ECM)
12042
12043 * cross section dependence on photon virtuality
12044       FSUP1 = ZERO
12045       DO  150 I=1,3
12046          FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
12047      &                             /(ONE+VIRT/PARMDL(30+I))**2
12048  150  CONTINUE
12049       FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
12050       FAC1  = FAC1*FSUP1
12051       FAC2  = FAC2*FSUP1
12052       FSUP2 = ONE
12053
12054       ECMOLD = ECM
12055       Q2OLD  = VIRT
12056
12057     3 CONTINUE
12058
12059 C     SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
12060       CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
12061       IF (ISHAD(1).EQ.1) THEN
12062          SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
12063       ELSE
12064          SIGDIR = ZERO
12065       ENDIF
12066       SIGANO = FSUP1*FSUP2*SIGANO
12067       SIGTOT = SIGTOT-SIGDIR-SIGANO
12068       SIGDIR = SIGDIR/(FSUP1*FSUP2)
12069       SIGANO = SIGANO/(FSUP1*FSUP2)
12070       SIGTOT = SIGTOT+SIGDIR+SIGANO
12071
12072       RR = DT_RNDM(SIGTOT)
12073       IF (RR.LT.SIGDIR/SIGTOT) THEN
12074          IPNT = 1
12075       ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
12076      &        (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
12077          IPNT = 2
12078       ELSE
12079          IPNT = 0
12080       ENDIF
12081       RPNT = (SIGDIR+SIGANO)/SIGTOT
12082 C     WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
12083 C     WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
12084 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
12085 C     WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
12086       IF (MODE.EQ.1) RETURN
12087
12088 **sr 22.7.97
12089       K1   = 1
12090       K2   = 1
12091       RATE = ZERO
12092       IF (ECM.GE.ECMNN(NEBINI)) THEN
12093          K1   = NEBINI
12094          K2   = NEBINI
12095          RATE = ONE
12096       ELSEIF (ECM.GT.ECMNN(1)) THEN
12097          DO 10 I=2,NEBINI
12098             IF (ECM.LT.ECMNN(I)) THEN
12099                K1   = I-1
12100                K2   = I
12101                RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
12102                GOTO 11
12103             ENDIF
12104    10    CONTINUE
12105    11    CONTINUE
12106       ENDIF
12107       J1   = 1
12108       J2   = 1
12109       RATQ = ZERO
12110       IF (NQBINI.GT.1) THEN
12111          IF (VIRT.GE.Q2G(NQBINI)) THEN
12112             J1   = NQBINI
12113             J2   = NQBINI
12114             RATQ = ONE
12115          ELSEIF (VIRT.GT.Q2G(1)) THEN
12116             DO 12 I=2,NQBINI
12117                IF (VIRT.LT.Q2G(I)) THEN
12118                   J1   = I-1
12119                   J2   = I
12120                   RATQ = LOG10(   VIRT/MAX(Q2G(J1),TINY14))/
12121      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
12122                   GOTO 13
12123                ENDIF
12124    12       CONTINUE
12125    13       CONTINUE
12126          ENDIF
12127       ENDIF
12128       SGA = XSPRO(K1,J1,NTARG)+
12129      &      RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
12130      &      RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
12131      &      RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
12132      &                 XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
12133       SDI = DBLE(NB)*SIGDIR
12134       SAN = DBLE(NB)*SIGANO
12135       SPL = SDI+SAN
12136       RR = DT_RNDM(SPL)
12137       IF (RR.LT.SDI/SGA) THEN
12138          IPNT = 1
12139       ELSEIF ((RR.GE.SDI/SGA).AND.
12140      &        (RR.LT.SPL/SGA)) THEN
12141          IPNT = 2
12142       ELSE
12143          IPNT = 0
12144       ENDIF
12145       RPNT = SPL/SGA
12146 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
12147 **
12148
12149       RETURN
12150       END
12151
12152 *$ CREATE DT_GLBINI.FOR
12153 *COPY DT_GLBINI
12154 *
12155 *===glbini=============================================================*
12156 *
12157       SUBROUTINE DT_GLBINI(WHAT)
12158
12159 ************************************************************************
12160 * Pre-initialization of profile function                               *
12161 * This version dated 28.11.00 is written by S. Roesler.                *
12162 *                                                                      *
12163 * Last change 27.12.2006 by S. Roesler.                                *
12164 ************************************************************************
12165
12166       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12167       SAVE
12168
12169       PARAMETER ( LINP = 10 ,
12170      &            LOUT = 6 ,
12171      &            LDAT = 9 )
12172
12173       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
12174
12175       LOGICAL LCMS
12176
12177 * particle properties (BAMJET index convention)
12178       CHARACTER*8  ANAME
12179       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12180      &                IICH(210),IIBAR(210),K1(210),K2(210)
12181
12182 * properties of interacting particles
12183       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12184
12185       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12186
12187 * emulsion treatment
12188       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12189      &                NCOMPO,IEMUL
12190
12191 * Glauber formalism: flags and parameters for statistics
12192       LOGICAL LPROD
12193       CHARACTER*8 CGLB
12194       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12195
12196 * number of data sets other than protons and nuclei
12197 * at the moment = 2 (pions and kaons)
12198       PARAMETER (MAXOFF=2)
12199       DIMENSION IJPINI(5),IOFFST(25)
12200       DATA IJPINI / 13, 15,  0,  0,  0/
12201 * Glauber data-set to be used for hadron projectiles
12202 * (0=proton, 1=pion, 2=kaon)
12203       DATA (IOFFST(K),K=1,25) /
12204      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12205      &  0, 0, 1, 2, 2/
12206 * Acceptance interval for target nucleus mass
12207       PARAMETER (KBACC = 6)
12208
12209 * flags for input different options
12210       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12211       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12212      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12213
12214       PARAMETER (MAXMSS = 100)
12215       DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
12216       DIMENSION WHAT(6)
12217
12218       DATA JPEACH,JPSTEP / 18, 5 /
12219
12220 * temporary patch until fix has been implemented in phojet:
12221 *  maximum energy for pion projectile
12222       DATA ECMXPI / 100000.0D0 /
12223 *
12224 *--------------------------------------------------------------------------
12225 * general initializations
12226 *
12227 *  steps in projectile mass number for initialization
12228       IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
12229       IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
12230 *
12231 *  energy range and binning
12232       ELO  = ABS(WHAT(1))
12233       EHI  = ABS(WHAT(2))
12234       IF (ELO.GT.EHI) ELO = EHI
12235       NEBIN = MAX(INT(WHAT(3)),1)
12236       IF (ELO.EQ.EHI) NEBIN = 0
12237       LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
12238       IF (LCMS) THEN
12239          ECMINI = EHI
12240       ELSE
12241          ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
12242      &                 +2.0D0*AAM(IJTARG)*EHI)
12243       ENDIF
12244 *
12245 *  default arguments for Glauber-routine
12246       XI  = ZERO
12247       Q2I = ZERO
12248 *
12249 *  initialize nuclear parameters, etc.
12250
12251 *  initialize evaporation if the code is not used as Fluka event generator
12252       IF (ITRSPT.NE.1) THEN
12253          CALL NCDTRD
12254          CALL INCINI
12255       ENDIF
12256
12257 *
12258 *  open Glauber-data output file
12259       IDX = INDEX(CGLB,' ')
12260       K   = 12
12261       IF (IDX.GT.1) K = IDX-1
12262       OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12263 *
12264 *--------------------------------------------------------------------------
12265 * Glauber-initialization for proton and nuclei projectiles
12266 *
12267 *  initialize phojet for proton-proton interactions
12268       ELAB = ZERO
12269       PLAB = ZERO
12270       CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12271       CALL DT_PHOINI
12272 *
12273 *  record projectile masses
12274       NASAV = 0
12275       NPROJ = MIN(IP,JPEACH)
12276       DO 10 KPROJ=1,NPROJ
12277          NASAV = NASAV+1
12278          IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12279          IASAV(NASAV) = KPROJ
12280    10 CONTINUE
12281       IF (IP.GT.JPEACH) THEN
12282          NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
12283          IF (NPROJ.EQ.0) THEN
12284             NASAV = NASAV+1
12285             IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12286             IASAV(NASAV) = IP
12287          ELSE
12288             DO 11 IPROJ=1,NPROJ
12289                KPROJ = JPEACH+IPROJ*JPSTEP
12290                NASAV = NASAV+1
12291                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12292                IASAV(NASAV) = KPROJ
12293    11       CONTINUE
12294             IF (KPROJ.LT.IP) THEN
12295                NASAV = NASAV+1
12296                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12297                IASAV(NASAV) = IP
12298             ENDIF
12299          ENDIF
12300       ENDIF
12301 *
12302 *  record target masses
12303       NBSAV = 0
12304       NTARG = 1
12305       IF (NCOMPO.GT.0) NTARG = NCOMPO
12306       DO 12 ITARG=1,NTARG
12307          NBSAV = NBSAV+1
12308          IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
12309          IF (NCOMPO.GT.0) THEN
12310             IBSAV(NBSAV) = IEMUMA(ITARG)
12311          ELSE
12312             IBSAV(NBSAV) = IT
12313          ENDIF
12314    12 CONTINUE
12315 *
12316 *  print masses
12317       WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
12318  1000 FORMAT(I4,A,1P,2E13.5)
12319       NLINES = DBLE(NASAV)/18.0D0
12320       IF (NLINES.GT.0) THEN
12321          DO 13 I=1,NLINES
12322             IF (I.EQ.1) THEN
12323                WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
12324             ELSE
12325                WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
12326             ENDIF
12327    13    CONTINUE
12328       ENDIF
12329       I0 = 18*NLINES+1
12330       IF (I0.LE.NASAV) THEN
12331          IF (I0.EQ.1) THEN
12332             WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
12333          ELSE
12334             WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
12335          ENDIF
12336       ENDIF
12337       NLINES = DBLE(NBSAV)/18.0D0
12338       IF (NLINES.GT.0) THEN
12339          DO 14 I=1,NLINES
12340             IF (I.EQ.1) THEN
12341                WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
12342             ELSE
12343                WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
12344             ENDIF
12345    14    CONTINUE
12346       ENDIF
12347       I0 = 18*NLINES+1
12348       IF (I0.LE.NBSAV) THEN
12349          IF (I0.EQ.1) THEN
12350             WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
12351          ELSE
12352             WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
12353          ENDIF
12354       ENDIF
12355 *
12356 *  calculate Glauber-data for each energy and mass combination
12357 *
12358 *   loop over energy bins
12359       ELO = LOG10(ELO)
12360       EHI = LOG10(EHI)
12361       DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
12362       DO 1 IE=1,NEBIN+1
12363          E = ELO+DBLE(IE-1)*DEBIN
12364          E = 10**E
12365          IF (LCMS) THEN
12366             E   = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
12367             ECM = E
12368          ELSE
12369             PLAB = ZERO
12370             ECM  = ZERO
12371             E    = MAX(AAM(IJPROJ)+0.1D0,E)
12372             CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12373          ENDIF
12374 *
12375 *   loop over projectile and target masses
12376          DO 2 ITARG=1,NBSAV
12377             DO 3 IPROJ=1,NASAV
12378                CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
12379      &                                       XI,Q2I,ECM,1,1,-1)
12380     3       CONTINUE
12381     2    CONTINUE
12382 *
12383     1 CONTINUE
12384 *
12385 *--------------------------------------------------------------------------
12386 * Glauber-initialization for pion, kaon, ... projectiles
12387 *
12388       DO 6 IJ=1,MAXOFF
12389 *
12390 *  initialize phojet for this interaction
12391          ELAB = ZERO
12392          PLAB = ZERO
12393          IJPROJ = IJPINI(IJ)
12394          IP     = 1
12395          IPZ    = 1
12396 *
12397 *   temporary patch until fix has been implemented in phojet:
12398          IF (ECMINI.GT.ECMXPI) THEN
12399             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
12400          ELSE
12401             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12402          ENDIF
12403          CALL DT_PHOINI
12404 *
12405 *  calculate Glauber-data for each energy and mass combination
12406 *
12407 *   loop over energy bins
12408          DO 4 IE=1,NEBIN+1
12409             E = ELO+DBLE(IE-1)*DEBIN
12410             E = 10**E
12411             IF (LCMS) THEN
12412                E   = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
12413                ECM = E
12414             ELSE
12415                PLAB = ZERO
12416                ECM  = ZERO
12417                E    = MAX(AAM(IJPROJ)+TINY14,E)
12418                CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12419             ENDIF
12420 *
12421 *   loop over projectile and target masses
12422             DO 5 ITARG=1,NBSAV
12423                CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
12424     5       CONTINUE
12425 *
12426     4    CONTINUE
12427 *
12428     6 CONTINUE
12429
12430 *--------------------------------------------------------------------------
12431 * close output unit(s), etc.
12432 *
12433       CLOSE(LDAT)
12434
12435       RETURN
12436       END
12437
12438 *$ CREATE DT_GLBSET.FOR
12439 *COPY DT_GLBSET
12440 *
12441 *===glbset=============================================================*
12442 *
12443       SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
12444 ************************************************************************
12445 * Interpolation of pre-initialized profile functions                   *
12446 * This version dated 28.11.00 is written by S. Roesler.                *
12447 ************************************************************************
12448
12449       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12450       SAVE
12451
12452       PARAMETER ( LINP = 10 ,
12453      &            LOUT = 6 ,
12454      &            LDAT = 9 )
12455
12456       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
12457
12458       LOGICAL LCMS,LREAD,LFRST1,LFRST2
12459
12460 * particle properties (BAMJET index convention)
12461       CHARACTER*8  ANAME
12462       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12463      &                IICH(210),IIBAR(210),K1(210),K2(210)
12464
12465 * Glauber formalism: flags and parameters for statistics
12466       LOGICAL LPROD
12467       CHARACTER*8 CGLB
12468       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12469
12470       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12471
12472 * Glauber formalism: parameters
12473       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
12474      &                BMAX(NCOMPX),BSTEP(NCOMPX),
12475      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
12476      &                NSITEB,NSTATB
12477
12478 * Glauber formalism: cross sections
12479       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
12480      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
12481      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
12482      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
12483      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
12484      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12485      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12486      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12487      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12488      &                BSLOPE,NEBINI,NQBINI
12489
12490 * number of data sets other than protons and nuclei
12491 * at the moment = 2 (pions and kaons)
12492       PARAMETER (MAXOFF=2)
12493       DIMENSION IJPINI(5),IOFFST(25)
12494       DATA IJPINI / 13, 15,  0,  0,  0/
12495 * Glauber data-set to be used for hadron projectiles
12496 * (0=proton, 1=pion, 2=kaon)
12497       DATA (IOFFST(K),K=1,25) /
12498      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12499      &  0, 0, 1, 2, 2/
12500 * Acceptance interval for target nucleus mass
12501       PARAMETER (KBACC = 6)
12502
12503 * emulsion treatment
12504       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12505      &                NCOMPO,IEMUL
12506
12507       PARAMETER (MAXSET=5000,
12508      &           MAXBIN=100)
12509       DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
12510       DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
12511      &          BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
12512      &          IAIDX(10)
12513
12514       DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
12515 *
12516 * read data from file
12517 *
12518       IF (MODE.EQ.0) THEN
12519
12520          IF (LREAD) RETURN
12521
12522          DO 1 I=1,MAXSET
12523             DO 2 J=1,6
12524                XSIG(I,J) = ZERO
12525                XERR(I,J) = ZERO
12526     2       CONTINUE
12527             DO 3 J=1,KSITEB
12528                BPROFL(I,J) = ZERO
12529     3       CONTINUE
12530     1    CONTINUE
12531          DO 4 I=1,MAXBIN
12532             IABIN(I) = 0
12533             IBBIN(I) = 0
12534     4    CONTINUE
12535          DO 5 I=1,KSITEB
12536             BPRO0(I) = ZERO
12537             BPRO1(I) = ZERO
12538             BPRO(I)  = ZERO
12539     5    CONTINUE
12540
12541          IDX = INDEX(CGLB,' ')
12542          K   = 12
12543          IF (IDX.GT.1) K = IDX-1
12544          OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12545          WRITE(LOUT,1000) CGLB(1:K)//'.glb'
12546  1000    FORMAT(/,' GLBSET: impact parameter distributions read from ',
12547      &          'file ',A12,/)
12548 *
12549 *  read binning information
12550          READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
12551 *  return lower energy threshold to Fluka-interface
12552          ELAB = ELO
12553          LCMS = ELO.LT.ZERO
12554          WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
12555          IF (LCMS) THEN
12556             WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
12557          ELSE
12558             WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
12559          ENDIF
12560  1001    FORMAT(2X,A5,'  E_lo = ',1P,E9.3,'  E_hi = ',1P,E9.3,4X,
12561      &          'No. of bins:',I5,/)
12562          ELO  = LOG10(ABS(ELO))
12563          EHI  = LOG10(ABS(EHI))
12564          DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
12565          WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
12566          READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
12567          IF (NABIN.LT.18) THEN
12568             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
12569          ELSE
12570             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
12571          ENDIF
12572          IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
12573          IF (NABIN.GT.18) THEN
12574             NLINES = DBLE(NABIN-18)/18.0D0
12575             IF (NLINES.GT.0) THEN
12576                DO 7 I=1,NLINES
12577                   I0 = 18*(I+1)-17
12578                   READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12579                   WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12580     7          CONTINUE
12581             ENDIF
12582             I0 = 18*(NLINES+1)+1
12583             IF (I0.LE.NABIN) THEN
12584                READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12585                WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12586             ENDIF
12587          ENDIF
12588          WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
12589          READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
12590          IF (NBBIN.LT.18) THEN
12591             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
12592          ELSE
12593             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12594          ENDIF
12595          IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
12596          IF (NBBIN.GT.18) THEN
12597             NLINES = DBLE(NBBIN-18)/18.0D0
12598             IF (NLINES.GT.0) THEN
12599                DO 8 I=1,NLINES
12600                   I0 = 18*(I+1)-17
12601                   READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12602                   WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12603     8          CONTINUE
12604             ENDIF
12605             I0 = 18*(NLINES+1)+1
12606             IF (I0.LE.NBBIN) THEN
12607                READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12608                WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12609             ENDIF
12610          ENDIF
12611 *  number of data sets to follow in the Glauber data file
12612 *   this variable is used for checks of consistency of projectile
12613 *   and target mass configurations given in header of Glauber data
12614 *   file and the data-sets which follow in this file
12615          NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12616 *
12617 *  read profile function data
12618          NSET  = 0
12619          NAIDX = 0
12620          IPOLD = 0
12621    10    CONTINUE
12622          NSET = NSET+1
12623          IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12624          READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12625  1002    FORMAT(5I10,E15.5)
12626          IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12627             NAIDX = NAIDX+1
12628             IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12629             IAIDX(NAIDX) = IP
12630             IPOLD = IP
12631          ENDIF
12632          READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12633          READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12634          NLINES = INT(DBLE(ISITEB)/7.0D0)
12635          IF (NLINES.GT.0) THEN
12636             DO 11 I=1,NLINES
12637                READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12638    11       CONTINUE
12639          ENDIF
12640          I0 = 7*NLINES+1
12641          IF (I0.LE.ISITEB)
12642      &      READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12643          GOTO 10
12644   100    CONTINUE
12645          NSET = NSET-1
12646          IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12647          WRITE(LOUT,'(/,1X,A)')
12648      &   ' projectiles other than protons and nuclei: (particle index)'
12649          IF (NAIDX.GT.0) THEN
12650             WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12651          ELSE
12652             WRITE(LOUT,'(6X,A)') 'none'
12653          ENDIF
12654 *
12655          CLOSE(LDAT)
12656          WRITE(LOUT,*)
12657          LREAD = .TRUE.
12658
12659          IF (NCOMPO.EQ.0) THEN
12660             DO 12 J=1,NBBIN
12661                NCOMPO = NCOMPO+1
12662                IEMUMA(NCOMPO) = IBBIN(J)
12663                IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12664                EMUFRA(NCOMPO) = 1.0D0
12665    12       CONTINUE
12666             IEMUL = 1
12667          ENDIF
12668 *
12669 * calculate profile function for certain set of parameters
12670 *
12671       ELSE
12672
12673 c        write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12674 *
12675 * check for type of projectile and set index-offset to entry in
12676 * Glauber data array correspondingly
12677          IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12678          IF (IOFFST(IDPROJ).EQ.-1) THEN
12679             STOP ' GLBSET: no data for this projectile !'
12680          ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12681             IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12682          ELSE
12683             IDXOFF = 0
12684          ENDIF
12685 *
12686 * get energy bin and interpolation factor
12687          IF (LCMS) THEN
12688             E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12689          ELSE
12690             E = ELAB
12691          ENDIF
12692          E = LOG10(E)
12693          IF (E.LT.ELO) THEN
12694             IF (LFRST1) THEN
12695                WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12696                LFRST1 = .FALSE.
12697             ENDIF
12698             E = ELO
12699          ENDIF
12700          IF (E.GT.EHI) THEN
12701             IF (LFRST2) THEN
12702                WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12703                LFRST2 = .FALSE.
12704             ENDIF
12705             E = EHI
12706          ENDIF
12707          IE0  = (E-ELO)/DEBIN+1
12708          IE1  = IE0+1
12709          FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12710 *
12711 * get target nucleus index
12712          KB = 0
12713          NBACC = KBACC
12714          DO 20 I=1,NBBIN
12715             NBDIFF = ABS(NB-IBBIN(I))
12716             IF (NB.EQ.IBBIN(I)) THEN
12717                KB = I
12718                GOTO 21
12719             ELSEIF (NBDIFF.LE.NBACC) THEN
12720                KB = I
12721                NBACC = NBDIFF
12722             ENDIF
12723    20    CONTINUE
12724          IF (KB.NE.0) GOTO 21
12725          WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12726          STOP
12727    21    CONTINUE
12728 *
12729 * get projectile nucleus bin and interpolation factor
12730          KA0 = 0
12731          KA1 = 0
12732          FACNA = 0
12733          IF (IDXOFF.GT.0) THEN
12734             KA0 = 1
12735             KA1 = 1
12736             KABIN = 1
12737          ELSE
12738             IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12739             DO 22 I=1,NABIN
12740                IF (NA.EQ.IABIN(I)) THEN
12741                   KA0 = I
12742                   KA1 = I
12743                   GOTO 23
12744                ELSEIF (NA.LT.IABIN(I)) THEN
12745                   KA0 = I-1
12746                   KA1 = I
12747                   GOTO 23
12748                ENDIF
12749    22       CONTINUE
12750             WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12751             STOP
12752    23       CONTINUE
12753             IF (KA0.NE.KA1)
12754      &         FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12755             KABIN = NABIN
12756          ENDIF
12757 *
12758 * interpolate profile functions for interactions ka0-kb and ka1-kb
12759 * for energy E separately
12760          IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12761          IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12762          IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12763          IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12764          DO 30 I=1,ISITEB
12765             BPRO0(I) = BPROFL(IDX0,I)
12766      &                 +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12767             BPRO1(I) = BPROFL(IDY0,I)
12768      &                 +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12769    30    CONTINUE
12770          RADB  = DT_RNCLUS(NB)
12771          BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12772          BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12773 *
12774 * interpolate cross sections for energy E and projectile mass
12775          DO 31 I=1,6
12776             XS0   = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12777             XS1   = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12778             XS(I) = XS0+FACNA*(XS1-XS0)
12779             XE0   = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12780             XE1   = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12781             XE(I) = XE0+FACNA*(XE1-XE0)
12782    31    CONTINUE
12783 *
12784 * interpolate between ka0 and ka1
12785          RADA = DT_RNCLUS(NA)
12786          BMX  = 2.0D0*(RADA+RADB)
12787          BSTP = BMX/DBLE(ISITEB-1)
12788          BPRO(1) = ZERO
12789          DO 32 I=1,ISITEB-1
12790             B = DBLE(I)*BSTP
12791 *
12792 *   calculate values of profile functions at B
12793             IDX0 = B/BSTP0+1
12794             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12795             IDX1 = MIN(IDX0+1,ISITEB)
12796             FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12797             BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12798             IDX0 = B/BSTP1+1
12799             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12800             IDX1 = MIN(IDX0+1,ISITEB)
12801             FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12802             BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12803 *
12804             BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12805    32    CONTINUE
12806 *
12807 * fill common dtglam
12808          NSITEB   = ISITEB
12809          RASH(1)  = RADA
12810          RBSH(1)  = RADB
12811          BMAX(1)  = BMX
12812          BSTEP(1) = BSTP
12813          DO 33 I=1,KSITEB
12814             BSITE(0,1,1,I) = BPRO(I)
12815    33    CONTINUE
12816 *
12817 * fill common dtglxs
12818          XSTOT(1,1,1) = XS(1)
12819          XSELA(1,1,1) = XS(2)
12820          XSQEP(1,1,1) = XS(3)
12821          XSQET(1,1,1) = XS(4)
12822          XSQE2(1,1,1) = XS(5)
12823          XSPRO(1,1,1) = XS(6)
12824          XETOT(1,1,1) = XE(1)
12825          XEELA(1,1,1) = XE(2)
12826          XEQEP(1,1,1) = XE(3)
12827          XEQET(1,1,1) = XE(4)
12828          XEQE2(1,1,1) = XE(5)
12829          XEPRO(1,1,1) = XE(6)
12830
12831       ENDIF
12832
12833       RETURN
12834       END
12835 *$ CREATE DT_XKSAMP.FOR
12836 *COPY DT_XKSAMP
12837 *
12838 *===xksamp=============================================================*
12839 *
12840       SUBROUTINE DT_XKSAMP(NN,ECM)
12841
12842 ************************************************************************
12843 * Sampling of parton x-values and chain system for one interaction.    *
12844 *                                   processed by S. Roesler, 9.8.95    *
12845 ************************************************************************
12846
12847       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12848       SAVE
12849
12850       PARAMETER ( LINP = 10 ,
12851      &            LOUT = 6 ,
12852      &            LDAT = 9 )
12853
12854       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12855       SAVE
12856
12857       PARAMETER (
12858 * lower cuts for (valence-sea/sea-valence) chain masses
12859 *   antiquark-quark (u/d-sea quark)    (s-sea quark)
12860      &               AMIU = 0.5D0,      AMIS = 0.8D0,
12861 *   quark-diquark   (u/d-sea quark)    (s-sea quark)
12862      &               AMAU = 2.6D0,      AMAS = 2.6D0,
12863 * maximum lower valence-x threshold
12864      &           XVMAX  = 0.98D0,
12865 * fraction of sea-diquarks sampled out of sea-partons
12866 **test
12867 C    &           FRCDIQ = 0.9D0,
12868 **
12869 *
12870      &           SQMA   = 0.7D0,
12871 *
12872 * maximum number of trials to generate x's for the required number
12873 * of sea quark pairs for a given hadron
12874      &           NSEATY = 12
12875 C    &           NSEATY = 3
12876      &          )
12877
12878       LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12879
12880       PARAMETER ( MAXNCL = 260,
12881
12882      &            MAXVQU = MAXNCL,
12883      &            MAXSQU = 20*MAXVQU,
12884      &            MAXINT = MAXVQU+MAXSQU)
12885
12886 * event history
12887
12888       PARAMETER (NMXHKK=200000)
12889
12890       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12891      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12892      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12893
12894 * particle properties (BAMJET index convention)
12895       CHARACTER*8  ANAME
12896       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12897      &                IICH(210),IIBAR(210),K1(210),K2(210)
12898
12899 * interface between Glauber formalism and DPM
12900       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12901      &                INTER1(MAXINT),INTER2(MAXINT)
12902
12903 * properties of interacting particles
12904       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12905
12906 * threshold values for x-sampling (DTUNUC 1.x)
12907       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12908      &                SSMIMQ,VVMTHR
12909
12910 * x-values of partons (DTUNUC 1.x)
12911       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12912      &                XTVQ(MAXVQU),XTVD(MAXVQU),
12913      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
12914      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
12915
12916 * flavors of partons (DTUNUC 1.x)
12917       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12918      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12919      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
12920      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12921      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
12922      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12923      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
12924
12925 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12926       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12927      &                IXPV,IXPS,IXTV,IXTS,
12928      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
12929      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
12930      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
12931      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
12932      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
12933      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
12934      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
12935      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
12936
12937 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12938       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12939      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12940
12941 * auxiliary common for chain system storage (DTUNUC 1.x)
12942       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12943
12944 * flags for input different options
12945       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12946       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12947      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12948
12949 * various options for treatment of partons (DTUNUC 1.x)
12950 * (chain recombination, Cronin,..)
12951       LOGICAL LCO2CR,LINTPT
12952       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12953      &                LCO2CR,LINTPT
12954
12955       DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12956      &          INTLO(MAXINT)
12957
12958 * (1) initializations
12959 *-----------------------------------------------------------------------
12960
12961 **test
12962       IF (ECM.LT.4.5D0) THEN
12963 C        FRCDIQ = 0.6D0
12964          FRCDIQ = 0.4D0
12965       ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12966 C        FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12967          FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12968       ELSE
12969 C        FRCDIQ = 0.9D0
12970          FRCDIQ = 0.7D0
12971       ENDIF
12972 **
12973       DO 30 I=1,MAXSQU
12974          ZUOSP(I) = .FALSE.
12975          ZUOST(I) = .FALSE.
12976          IF (I.LE.MAXVQU) THEN
12977             ZUOVP(I) = .FALSE.
12978             ZUOVT(I) = .FALSE.
12979          ENDIF
12980    30 CONTINUE
12981
12982 * lower thresholds for x-selection
12983 *  sea-quarks       (default: CSEA=0.2)
12984       IF (ECM.LT.10.0D0) THEN
12985 **!!test
12986          XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12987 C        XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12988          NSEA  = NSEATY
12989 C        XSTHR = ONE/ECM**2
12990       ELSE
12991 **sr 30.3.98
12992 C        XSTHR = CSEA/ECM
12993          XSTHR = CSEA/ECM**2
12994 C        XSTHR = ONE/ECM**2
12995 **
12996          IF ((IP.GE.150).AND.(IT.GE.150))
12997      &      XSTHR = 2.5D0/(ECM*SQRT(ECM))
12998          NSEA  = NSEATY
12999       ENDIF
13000 *                   (default: SSMIMA=0.14) used for sea-diquarks (?)
13001       XSSTHR = SSMIMA/ECM
13002       BSQMA  = SQMA/ECM
13003 *  valence-quarks   (default: CVQ=1.0)
13004       XVTHR  = CVQ/ECM
13005 *  valence-diquarks (default: CDQ=2.0)
13006       XDTHR  = CDQ/ECM
13007
13008 * maximum-x for sea-quarks
13009       XVCUT  = XVTHR+XDTHR
13010       IF (XVCUT.GT.XVMAX) THEN
13011          XVCUT = XVMAX
13012          XVTHR = XVCUT/3.0D0
13013          XDTHR = XVCUT-XVTHR
13014       ENDIF
13015       XXSEAM = ONE-XVCUT
13016 **sr 18.4. test: DPMJET
13017 C     XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
13018 C    &            - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
13019 C    &             -0.01*(1.D0+1.5D0*DT_RNDM(V3))
13020 **
13021 * maximum number of sea-pairs allowed kinematically
13022 C     NSMAX  = INT(OHALF*XXSEAM/XSTHR)
13023       RNSMAX = OHALF*XXSEAM/XSTHR
13024       IF (RNSMAX.GT.10000.0D0) THEN
13025          NSMAX = 10000
13026       ELSE
13027          NSMAX = INT(OHALF*XXSEAM/XSTHR)
13028       ENDIF
13029 * check kinematical limit for valence-x thresholds
13030 * (should be obsolete now)
13031       IF (XVCUT.GT.XVMAX) THEN
13032          WRITE(LOUT,1000) XVCUT,ECM
13033  1000    FORMAT(' XKSAMP:    kin. limit for valence-x',
13034      &          '  thresholds not allowed (',2E9.3,')')
13035 C        XVTHR = XVMAX-XDTHR
13036 C        IF (XVTHR.LT.ZERO) STOP
13037          STOP
13038       ENDIF
13039
13040 * set eta for valence-x sampling (BETREJ)
13041 *   (UNON per default, UNOM used for projectile mesons only)
13042       IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
13043          UNOPRV = UNOM
13044       ELSE
13045          UNOPRV = UNON
13046       ENDIF
13047
13048 * (2) select parton x-values of interacting projectile nucleons
13049 *-----------------------------------------------------------------------
13050
13051       IXPV = 0
13052       IXPS = 0
13053
13054       DO 100 IPP=1,IP
13055 *   get interacting projectile nucleon as sampled by Glauber
13056          IF (JSSH(IPP).NE.0) THEN
13057             IXSTMP = IXPS
13058             IXVTMP = IXPV
13059    99       CONTINUE
13060             IXPS   = IXSTMP
13061             IXPV   = IXVTMP
13062 *     JIPP is the actual number of sea-pairs sampled for this nucleon
13063             JIPP   = MIN(JSSH(IPP)-1,NSMAX)
13064    41       CONTINUE
13065             XXSEA  = ZERO
13066             IF (JIPP.GT.0) THEN
13067                XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
13068 *???
13069                IF (XSTHR.GE.XSMAX) THEN
13070                   JIPP = JIPP-1
13071                   GOTO 41
13072                ENDIF
13073
13074 *>>>get x-values of sea-quark pairs
13075                NSCOUN = 0
13076                PLW = 0.5D0
13077    40          CONTINUE
13078 *     accumulator for sea x-values
13079                XXSEA  = ZERO
13080                NSCOUN = NSCOUN+1
13081                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13082                IF (NSCOUN.GT.NSEA) THEN
13083 *     decrease the number of interactions after NSEA trials
13084                   JIPP   = JIPP-1
13085                   NSCOUN = 0
13086                ENDIF
13087                DO 70 ISQ=1,JIPP
13088 *     sea-quarks
13089                   IF (IPSQ(IXPS+1).LE.2) THEN
13090 **sr 8.4.98 (1/sqrt(x))
13091 C                    XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13092 C                    XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13093                      XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13094 **
13095                   ELSE
13096                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13097                         XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13098                      ELSE
13099 **sr 8.4.98 (1/sqrt(x))
13100 C                       XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13101 C                       XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13102                         XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13103 **
13104                      ENDIF
13105                   ENDIF
13106 *     sea-antiquarks
13107                   IF (IPSAQ(IXPS+1).GE.-2) THEN
13108 **sr 8.4.98 (1/sqrt(x))
13109 C                    XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13110 C                    XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13111                      XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13112 **
13113                   ELSE
13114                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13115                         XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13116                      ELSE
13117 **sr 8.4.98 (1/sqrt(x))
13118 C                       XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13119 C                       XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13120                         XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13121 **
13122                      ENDIF
13123                   ENDIF
13124                   XXSEA = XXSEA+XPSQI+XPSAQI
13125 *     check for maximum allowed sea x-value
13126                   IF (XXSEA.GE.XXSEAM) THEN
13127                      IXPS = IXPS-ISQ+1
13128                      GOTO 40
13129                   ENDIF
13130 *     accept this sea-quark pair
13131                   IXPS         = IXPS+1
13132                   XPSQ(IXPS)   = XPSQI
13133                   XPSAQ(IXPS)  = XPSAQI
13134                   IFROSP(IXPS) = IPP
13135                   ZUOSP(IXPS)  = .TRUE.
13136    70          CONTINUE
13137             ENDIF
13138
13139 *>>>get x-values of valence partons
13140 *     valence quark
13141             IF (XVTHR.GT.0.05D0) THEN
13142                XVHI  = ONE-XXSEA-XDTHR
13143                XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
13144             ELSE
13145    90          CONTINUE
13146                XPVQI = DT_DBETAR(OHALF,UNOPRV)
13147                IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
13148      &                                                     GOTO 90
13149             ENDIF
13150 *     valence diquark
13151             XPVDI = ONE-XPVQI-XXSEA
13152 *       reject according to x**1.5
13153             XDTMP = XPVDI**1.5D0
13154             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
13155 *     accept these valence partons
13156             IXPV         = IXPV+1
13157             XPVQ(IXPV)   = XPVQI
13158             XPVD(IXPV)   = XPVDI
13159             IFROVP(IXPV) = IPP
13160             ITOVP(IPP)   = IXPV
13161             ZUOVP(IXPV)  = .TRUE.
13162
13163          ENDIF
13164   100 CONTINUE
13165
13166 * (3) select parton x-values of interacting target nucleons
13167 *-----------------------------------------------------------------------
13168
13169       IXTV = 0
13170       IXTS = 0
13171
13172       DO 170 ITT=1,IT
13173 *   get interacting target nucleon as sampled by Glauber
13174          IF (JTSH(ITT).NE.0) THEN
13175             IXSTMP = IXTS
13176             IXVTMP = IXTV
13177   169       CONTINUE
13178             IXTS   = IXSTMP
13179             IXTV   = IXVTMP
13180 *     JITT is the actual number of sea-pairs sampled for this nucleon
13181             JITT   = MIN(JTSH(ITT)-1,NSMAX)
13182   111       CONTINUE
13183             XXSEA  = ZERO
13184             IF (JITT.GT.0) THEN
13185                XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
13186 *???
13187                IF (XSTHR.GE.XSMAX) THEN
13188                   JITT = JITT-1
13189                   GOTO 111
13190                ENDIF
13191
13192 *>>>get x-values of sea-quark pairs
13193                NSCOUN = 0
13194                PLW = 0.5D0
13195   110          CONTINUE
13196 *     accumulator for sea x-values
13197                XXSEA  = ZERO
13198                NSCOUN = NSCOUN+1
13199                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13200                IF (NSCOUN.GT.NSEA)THEN
13201 *     decrease the number of interactions after NSEA trials
13202                   JITT   = JITT-1
13203                   NSCOUN = 0
13204                ENDIF
13205                DO 140 ISQ=1,JITT
13206 *     sea-quarks
13207                   IF (ITSQ(IXTS+1).LE.2) THEN
13208 **sr 8.4.98 (1/sqrt(x))
13209 C                    XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13210 C                    XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13211                      XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13212 **
13213                   ELSE
13214                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13215                         XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13216                      ELSE
13217 **sr 8.4.98 (1/sqrt(x))
13218 C                       XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13219 C                       XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13220                         XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13221 **
13222                      ENDIF
13223                   ENDIF
13224 *     sea-antiquarks
13225                   IF (ITSAQ(IXTS+1).GE.-2) THEN
13226 **sr 8.4.98 (1/sqrt(x))
13227 C                    XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13228 C                    XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13229                      XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13230 **
13231                   ELSE
13232                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13233                         XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13234                      ELSE
13235 **sr 8.4.98 (1/sqrt(x))
13236 C                       XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13237 C                       XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13238                         XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13239 **
13240                      ENDIF
13241                   ENDIF
13242                   XXSEA = XXSEA+XTSQI+XTSAQI
13243 *     check for maximum allowed sea x-value
13244                   IF (XXSEA.GE.XXSEAM) THEN
13245                      IXTS = IXTS-ISQ+1
13246                      GOTO 110
13247                   ENDIF
13248 *     accept this sea-quark pair
13249                   IXTS         = IXTS+1
13250                   XTSQ(IXTS)   = XTSQI
13251                   XTSAQ(IXTS)  = XTSAQI
13252                   IFROST(IXTS) = ITT
13253                   ZUOST(IXTS)  = .TRUE.
13254   140          CONTINUE
13255             ENDIF
13256
13257 *>>>get x-values of valence partons
13258 *     valence quark
13259             IF (XVTHR.GT.0.05D0) THEN
13260                XVHI  = ONE-XXSEA-XDTHR
13261                XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
13262             ELSE
13263   160          CONTINUE
13264                XTVQI = DT_DBETAR(OHALF,UNON)
13265                IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
13266      &                                                    GOTO 160
13267             ENDIF
13268 *     valence diquark
13269             XTVDI = ONE-XTVQI-XXSEA
13270 *       reject according to x**1.5
13271             XDTMP = XTVDI**1.5D0
13272             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
13273 *     accept these valence partons
13274             IXTV         = IXTV+1
13275             XTVQ(IXTV)   = XTVQI
13276             XTVD(IXTV)   = XTVDI
13277             IFROVT(IXTV) = ITT
13278             ITOVT(ITT)   = IXTV
13279             ZUOVT(IXTV)  = .TRUE.
13280
13281          ENDIF
13282   170 CONTINUE
13283
13284 * (4) get valence-valence chains
13285 *-----------------------------------------------------------------------
13286
13287       NVV = 0
13288       DO 240 I=1,NN
13289          INTLO(I) = .TRUE.
13290          IPVAL    = ITOVP(INTER1(I))
13291          ITVAL    = ITOVT(INTER2(I))
13292          IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
13293             INTLO(I)      = .FALSE.
13294             ZUOVP(IPVAL)  = .FALSE.
13295             ZUOVT(ITVAL)  = .FALSE.
13296             NVV           = NVV+1
13297             ISKPCH(8,NVV) = 0
13298             INTVV1(NVV)   = IPVAL
13299             INTVV2(NVV)   = ITVAL
13300          ENDIF
13301   240 CONTINUE
13302
13303 * (5) get sea-valence chains
13304 *-----------------------------------------------------------------------
13305
13306       NSV = 0
13307       NDV = 0
13308       PLW = 0.5D0
13309       DO 270 I=1,NN
13310          IF (INTLO(I)) THEN
13311             IPVAL = ITOVP(INTER1(I))
13312             ITVAL = ITOVT(INTER2(I))
13313             DO 250 J=1,IXPS
13314                IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
13315      &                                ZUOVT(ITVAL)) THEN
13316                   ZUOSP(J)     = .FALSE.
13317                   ZUOVT(ITVAL) = .FALSE.
13318                   INTLO(I)     = .FALSE.
13319                   IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
13320 *   sample sea-diquark pair
13321                      CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
13322                      IF (IREJ1.EQ.0) GOTO 260
13323                   ENDIF
13324                   NSV           = NSV+1
13325                   ISKPCH(4,NSV) = 0
13326                   INTSV1(NSV)   = J
13327                   INTSV2(NSV)   = ITVAL
13328
13329 *>>>correct chain kinematics according to minimum chain masses
13330 *     the actual chain masses
13331                   AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
13332                   AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
13333 *     get lower mass cuts
13334                   IF (IPSQ(J).EQ.3) THEN
13335 *       q being s-quark
13336                      AMCHK1 = AMAS
13337                      AMCHK2 = AMIS
13338                   ELSE
13339 *       q being u/d-quark
13340                      AMCHK1 = AMAU
13341                      AMCHK2 = AMIU
13342                   ENDIF
13343 *       q-qq chain
13344 *         chain mass above minimum - resampling of sea-q x-value
13345                   IF (AMSVQ1.GT.AMCHK1) THEN
13346                      XPSQTH      = AMCHK1/(XTVD(ITVAL)*ECM**2)
13347 **sr 8.4.98 (1/sqrt(x))
13348 C                    XPSQXX      = DT_SAMPEX(XPSQTH,XPSQ(J))
13349 C                    XPSQXX      = DT_SAMSQX(XPSQTH,XPSQ(J))
13350                      XPSQXX      = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
13351 **
13352                      XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
13353                      XPSQ(J)     = XPSQXX
13354 *         chain mass below minimum - reset sea-q x-value and correct
13355 *                                    diquark-x of the same nucleon
13356                   ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13357                      XPSQW       = AMCHK1/(XTVD(ITVAL)*ECM**2)
13358                      DXPSQ       = XPSQW-XPSQ(J)
13359                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13360                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13361                         XPSQ(J)     = XPSQW
13362                      ENDIF
13363                   ENDIF
13364 *       aq-q chain
13365 *         chain mass below minimum - reset sea-aq x-value and correct
13366 *                                    diquark-x of the same nucleon
13367                   IF (AMSVQ2.LT.AMCHK2) THEN
13368                      XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
13369                      DXPSQ = XPSQW-XPSAQ(J)
13370                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13371                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13372                         XPSAQ(J)    = XPSQW
13373                      ENDIF
13374                   ENDIF
13375 *>>>end of chain mass correction
13376
13377                   GOTO 260
13378                ENDIF
13379   250       CONTINUE
13380          ENDIF
13381   260    CONTINUE
13382   270 CONTINUE
13383
13384 * (6) get valence-sea chains
13385 *-----------------------------------------------------------------------
13386
13387       NVS = 0
13388       NVD = 0
13389       DO 300 I=1,NN
13390          IF (INTLO(I)) THEN
13391             IPVAL = ITOVP(INTER1(I))
13392             ITVAL = ITOVT(INTER2(I))
13393             DO 280 J=1,IXTS
13394                IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
13395      &                  (IFROST(J).EQ.INTER2(I))) THEN
13396                   ZUOST(J)     = .FALSE.
13397                   ZUOVP(IPVAL) = .FALSE.
13398                   INTLO(I)     = .FALSE.
13399                   IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13400 *   sample sea-diquark pair
13401                      CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
13402                      IF (IREJ1.EQ.0) GOTO 290
13403                   ENDIF
13404                   NVS           = NVS + 1
13405                   ISKPCH(6,NVS) = 0
13406                   INTVS1(NVS)   = IPVAL
13407                   INTVS2(NVS)   = J
13408
13409 *>>>correct chain kinematics according to minimum chain masses
13410 *     the actual chain masses
13411                   AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
13412                   AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
13413 *     get lower mass cuts
13414                   IF (ITSQ(J).EQ.3) THEN
13415 *       q being s-quark
13416                      AMCHK1 = AMIS
13417                      AMCHK2 = AMAS
13418                   ELSE
13419 *       q being u/d-quark
13420                      AMCHK1 = AMIU
13421                      AMCHK2 = AMAU
13422                   ENDIF
13423 *       q-aq chain
13424 *         chain mass below minimum - reset sea-aq x-value and correct
13425 *                                    diquark-x of the same nucleon
13426                   IF (AMVSQ1.LT.AMCHK1) THEN
13427                      XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
13428                      DXTSQ = XTSQW-XTSAQ(J)
13429                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13430                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13431                         XTSAQ(J)    = XTSQW
13432                      ENDIF
13433                   ENDIF
13434 *       qq-q chain
13435 *         chain mass above minimum - resampling of sea-q x-value
13436                   IF (AMVSQ2.GT.AMCHK2) THEN
13437                      XTSQTH      = AMCHK2/(XPVD(IPVAL)*ECM**2)
13438 **sr 8.4.98 (1/sqrt(x))
13439 C                    XTSQXX      = DT_SAMPEX(XTSQTH,XTSQ(J))
13440 C                    XTSQXX      = DT_SAMSQX(XTSQTH,XTSQ(J))
13441                      XTSQXX      = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13442 **
13443                      XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
13444                      XTSQ(J)     = XTSQXX
13445 *         chain mass below minimum - reset sea-q x-value and correct
13446 *                                    diquark-x of the same nucleon
13447                   ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13448                      XTSQW       = AMCHK2/(XPVD(IPVAL)*ECM**2)
13449                      DXTSQ       = XTSQW-XTSQ(J)
13450                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13451                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13452                         XTSQ(J)     = XTSQW
13453                      ENDIF
13454                   ENDIF
13455 *>>>end of chain mass correction
13456
13457                   GOTO 290
13458                ENDIF
13459   280       CONTINUE
13460          ENDIF
13461   290    CONTINUE
13462   300 CONTINUE
13463
13464 * (7) get sea-sea chains
13465 *-----------------------------------------------------------------------
13466
13467       NSS = 0
13468       NDS = 0
13469       NSD = 0
13470       DO 420 I=1,NN
13471          IF (INTLO(I)) THEN
13472             IPVAL = ITOVP(INTER1(I))
13473             ITVAL = ITOVT(INTER2(I))
13474 *   loop over target partons not yet matched
13475             DO 400 J=1,IXTS
13476                IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
13477 *   loop over projectile partons not yet matched
13478                   DO 390 JJ=1,IXPS
13479                      IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
13480                         ZUOSP(JJ)     = .FALSE.
13481                         ZUOST(J)      = .FALSE.
13482                         INTLO(I)      = .FALSE.
13483                         NSS           = NSS+1
13484                         ISKPCH(1,NSS) = 0
13485                         INTSS1(NSS)   = JJ
13486                         INTSS2(NSS)   = J
13487
13488 *---->chain recombination option
13489                         VALFRA        = DBLE(NVV/(NVV+IXPS+IXTS))
13490                         IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
13491      &                                                             THEN
13492 *       sea-sea chains may recombine with valence-valence chains
13493 *       only if they have the same projectile or target nucleon
13494                            DO 4201 IVV=1,NVV
13495                               IF (ISKPCH(8,IVV).NE.99) THEN
13496                                  IXVPR = INTVV1(IVV)
13497                                  IXVTA = INTVV2(IVV)
13498                                  IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
13499      &                               (INTER2(I).EQ.IFROVT(IXVTA))) THEN
13500 *         recombination possible, drop old v-v and s-s chains
13501                                     ISKPCH(1,NSS) = 99
13502                                     ISKPCH(8,IVV) = 99
13503
13504 *         (a) assign new s-v chains
13505 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
13506                                     IF (LSEADI.AND.
13507      &                                  (DT_RNDM(VALFRA).GT.FRCDIQ))
13508      &                                                             THEN
13509 *           sample sea-diquark pair
13510                                        CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
13511      &                                                      IREJ1)
13512                                        IF (IREJ1.EQ.0) GOTO 4202
13513                                     ENDIF
13514                                     NSV           = NSV+1
13515                                     ISKPCH(4,NSV) = 0
13516                                     INTSV1(NSV)   = JJ
13517                                     INTSV2(NSV)   = IXVTA
13518 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13519 *           the actual chain masses
13520                                     AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
13521      &                                                     *ECM**2
13522                                     AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
13523      &                                                     *ECM**2
13524 *           get lower mass cuts
13525                                     IF (IPSQ(JJ).EQ.3) THEN
13526 *             q being s-quark
13527                                        AMCHK1 = AMAS
13528                                        AMCHK2 = AMIS
13529                                     ELSE
13530 *             q being u/d-quark
13531                                        AMCHK1 = AMAU
13532                                        AMCHK2 = AMIU
13533                                     ENDIF
13534 *           q-qq chain
13535 *             chain mass above minimum - resampling of sea-q x-value
13536                                     IF (AMSVQ1.GT.AMCHK1) THEN
13537                                        XPSQTH      =
13538      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
13539 **sr 8.4.98 (1/sqrt(x))
13540                                        XPSQXX      =
13541      &                                    DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
13542 C    &                                    DT_SAMSQX(XPSQTH,XPSQ(JJ))
13543 C    &                                    DT_SAMPEX(XPSQTH,XPSQ(JJ))
13544 **
13545                                        XPVD(IPVAL) =
13546      &                                    XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
13547                                        XPSQ(JJ)    = XPSQXX
13548 *             chain mass below minimum - reset sea-q x-value and correct
13549 *                                        diquark-x of the same nucleon
13550                                     ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13551                                        XPSQW =
13552      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
13553                                        DXPSQ = XPSQW-XPSQ(JJ)
13554                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13555      &                                                            THEN
13556                                           XPVD(IPVAL) =
13557      &                                       XPVD(IPVAL)-DXPSQ
13558                                           XPSQ(JJ)    = XPSQW
13559                                        ENDIF
13560                                     ENDIF
13561 *           aq-q chain
13562 *             chain mass below minimum - reset sea-aq x-value and correct
13563 *                                        diquark-x of the same nucleon
13564                                     IF (AMSVQ2.LT.AMCHK2) THEN
13565                                        XPSQW =
13566      &                                    AMCHK2/(XTVQ(IXVTA)*ECM**2)
13567                                        DXPSQ = XPSQW-XPSAQ(JJ)
13568                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13569      &                                                            THEN
13570                                           XPVD(IPVAL) =
13571      &                                       XPVD(IPVAL)-DXPSQ
13572                                           XPSAQ(JJ)   = XPSQW
13573                                        ENDIF
13574                                     ENDIF
13575 *>>>>>>>>>>>end of chain mass correction
13576  4202                               CONTINUE
13577
13578 *         (b) assign new v-s chains
13579 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
13580                                     IF (LSEADI.AND.(
13581      &                                  DT_RNDM(AMSVQ2).GT.FRCDIQ))
13582      &                                                             THEN
13583 *           sample sea-diquark pair
13584                                        CALL DT_SAMSDQ(ECM,IXVPR,J,1,
13585      &                                                      IREJ1)
13586                                        IF (IREJ1.EQ.0) GOTO 4203
13587                                     ENDIF
13588                                     NVS           = NVS+1
13589                                     ISKPCH(6,NVS) = 0
13590                                     INTVS1(NVS)   = IXVPR
13591                                     INTVS2(NVS)   = J
13592 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13593 *           the actual chain masses
13594                                     AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
13595                                     AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
13596 *           get lower mass cuts
13597                                     IF (ITSQ(J).EQ.3) THEN
13598 *             q being s-quark
13599                                        AMCHK1 = AMIS
13600                                        AMCHK2 = AMAS
13601                                     ELSE
13602 *             q being u/d-quark
13603                                        AMCHK1 = AMIU
13604                                        AMCHK2 = AMAU
13605                                     ENDIF
13606 *           q-aq chain
13607 *             chain mass below minimum - reset sea-aq x-value and correct
13608 *                                        diquark-x of the same nucleon
13609                                     IF (AMVSQ1.LT.AMCHK1) THEN
13610                                        XTSQW =
13611      &                                    AMCHK1/(XPVQ(IXVPR)*ECM**2)
13612                                        DXTSQ = XTSQW-XTSAQ(J)
13613                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13614      &                                                            THEN
13615                                           XTVD(ITVAL) =
13616      &                                       XTVD(ITVAL)-DXTSQ
13617                                           XTSAQ(J)    = XTSQW
13618                                        ENDIF
13619                                     ENDIF
13620                                     IF (AMVSQ2.GT.AMCHK2) THEN
13621                                        XTSQTH      =
13622      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13623 **sr 8.4.98 (1/sqrt(x))
13624                                        XTSQXX      =
13625      &                                    DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13626 C    &                                    DT_SAMSQX(XTSQTH,XTSQ(J))
13627 C    &                                    DT_SAMPEX(XTSQTH,XTSQ(J))
13628 **
13629                                        XTVD(ITVAL) =
13630      &                                    XTVD(ITVAL)+XTSQ(J)-XTSQXX
13631                                        XTSQ(J)     = XTSQXX
13632                                     ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13633                                        XTSQW =
13634      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13635                                        DXTSQ = XTSQW-XTSQ(J)
13636                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13637      &                                                            THEN
13638                                           XTVD(ITVAL) =
13639      &                                       XTVD(ITVAL)-DXTSQ
13640                                           XTSQ(J)     = XTSQW
13641                                        ENDIF
13642                                     ENDIF
13643 *>>>>>>>>>end of chain mass correction
13644  4203                               CONTINUE
13645 *       jump out of s-s chain loop
13646                                     GOTO 420
13647                                  ENDIF
13648                               ENDIF
13649  4201                      CONTINUE
13650                         ENDIF
13651 *---->end of chain recombination option
13652
13653 *     sample sea-diquark pair (projectile)
13654                         IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13655                            CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13656                            IF (IREJ1.EQ.0) THEN
13657                               ISKPCH(1,NSS) = 99
13658                               GOTO 410
13659                            ENDIF
13660                         ENDIF
13661 *     sample sea-diquark pair (target)
13662                         IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13663                            CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13664                            IF (IREJ1.EQ.0) THEN
13665                               ISKPCH(1,NSS) = 99
13666                               GOTO 410
13667                            ENDIF
13668                         ENDIF
13669 *>>>>>correct chain kinematics according to minimum chain masses
13670 *     the actual chain masses
13671                         SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13672                         SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13673 *     check for lower mass cuts
13674                         IF ((SSMA1Q.LT.SSMIMQ).OR.
13675      &                      (SSMA2Q.LT.SSMIMQ)) THEN
13676                            IPVAL = ITOVP(INTER1(I))
13677                            ITVAL = ITOVT(INTER2(I))
13678                            IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13679      &                         (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13680 *       maximum allowed x values for sea quarks
13681                               XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13682      &                                           1.2D0*XSSTHR
13683                               XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13684      &                                           1.2D0*XSSTHR
13685 *       resampling of x values not possible - skip sea-sea chains
13686                               IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13687      &                            (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13688 *       resampling of x for projectile sea quark pair
13689                               ICOUS = 0
13690   310                         CONTINUE
13691                               ICOUS = ICOUS+1
13692                               IF (XSSTHR.GT.0.05D0) THEN
13693                                  XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13694      &                                                         XSPMAX)
13695                                  XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13696      &                                                         XSPMAX)
13697                               ELSE
13698   320                            CONTINUE
13699                                  XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13700                                  IF ((XPSQI.LT.XSSTHR).OR.
13701      &                               (XPSQI.GT.XSPMAX))  GOTO 320
13702   330                            CONTINUE
13703                                  XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13704                                  IF ((XPSAQI.LT.XSSTHR).OR.
13705      &                               (XPSAQI.GT.XSPMAX)) GOTO 330
13706                               ENDIF
13707 *       final test of remaining x for projectile diquark
13708                               XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13709      &                                            +XPSQ(JJ)+XPSAQ(JJ)
13710                               IF (XPVDCO.LE.XDTHR) THEN
13711 *!!!
13712 C                                IF (ICOUS.LT.5) GOTO 310
13713                                  IF (ICOUS.LT.0.5D0) GOTO 310
13714                                  GOTO 380
13715                               ENDIF
13716 *       resampling of x for target sea quark pair
13717                               ICOUS = 0
13718   350                         CONTINUE
13719                               ICOUS = ICOUS+1
13720                               IF (XSSTHR.GT.0.05D0) THEN
13721                                  XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13722      &                                                         XSTMAX)
13723                                  XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13724      &                                                         XSTMAX)
13725                               ELSE
13726   360                            CONTINUE
13727                                  XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13728                                  IF ((XTSQI.LT.XSSTHR).OR.
13729      &                               (XTSQI.GT.XSTMAX))  GOTO 360
13730   370                            CONTINUE
13731                                  XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13732                                  IF ((XTSAQI.LT.XSSTHR).OR.
13733      &                               (XTSAQI.GT.XSTMAX)) GOTO 370
13734                               ENDIF
13735 *       final test of remaining x for target diquark
13736                               XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13737      &                                            +XTSQ(J)+XTSAQ(J)
13738                               IF (XTVDCO.LT.XDTHR) THEN
13739                                  IF (ICOUS.LT.5) GOTO 350
13740                                  GOTO 380
13741                               ENDIF
13742                               XPVD(IPVAL) = XPVDCO
13743                               XTVD(ITVAL) = XTVDCO
13744                               XPSQ(JJ)    = XPSQI
13745                               XPSAQ(JJ)   = XPSAQI
13746                               XTSQ(J)     = XTSQI
13747                               XTSAQ(J)    = XTSAQI
13748 *>>>>>end of chain mass correction
13749                               GOTO 410
13750                            ENDIF
13751 *     come here to discard s-s interaction
13752 *     resampling of x values not allowed or unsuccessful
13753   380                      CONTINUE
13754                            INTLO(I)  = .FALSE.
13755                            ZUOST(J)  = .TRUE.
13756                            ZUOSP(JJ) = .TRUE.
13757                            NSS       = NSS-1
13758                         ENDIF
13759 *   consider next s-s interaction
13760                         GOTO 410
13761                      ENDIF
13762   390             CONTINUE
13763                ENDIF
13764   400       CONTINUE
13765          ENDIF
13766   410    CONTINUE
13767   420 CONTINUE
13768
13769 * correct x-values of valence quarks for non-matching sea quarks
13770       DO 430 I=1,IXPS
13771          IF (ZUOSP(I)) THEN
13772             IPVAL       = ITOVP(IFROSP(I))
13773             XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13774             XPSQ(I)     = ZERO
13775             XPSAQ(I)    = ZERO
13776             ZUOSP(I)    = .FALSE.
13777          ENDIF
13778   430 CONTINUE
13779       DO 440 I=1,IXTS
13780          IF (ZUOST(I)) THEN
13781             ITVAL       = ITOVT(IFROST(I))
13782             XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13783             XTSQ(I)     = ZERO
13784             XTSAQ(I)    = ZERO
13785             ZUOST(I)    = .FALSE.
13786          ENDIF
13787   440 CONTINUE
13788       DO 450 I=1,IXPV
13789          IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13790   450 CONTINUE
13791       DO 460 I=1,IXTV
13792          IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13793   460 CONTINUE
13794
13795       RETURN
13796       END
13797
13798 *$ CREATE DT_SAMSDQ.FOR
13799 *COPY DT_SAMSDQ
13800 *
13801 *===samsdq=============================================================*
13802 *
13803       SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13804
13805 ************************************************************************
13806 * SAMpling of Sea-DiQuarks                                             *
13807 *              ECM        cm-energy of the nucleon-nucleon system      *
13808 *              IDX1,2     indices of x-values of the participating     *
13809 *                         partons (IDX2 is always the sea-q-pair to be *
13810 *                         changed to sea-qq-pair)                      *
13811 *              MODE       = 1  valence-q - sea-diq                     *
13812 *                         = 2  sea-diq   - valence-q                   *
13813 *                         = 3  sea-q     - sea-diq                     *
13814 *                         = 4  sea-diq   - sea-q                       *
13815 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS.                               *
13816 * This version dated 17.10.95 is written by S. Roesler                 *
13817 ************************************************************************
13818
13819       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13820       SAVE
13821
13822       PARAMETER (ZERO=0.0D0)
13823
13824 * threshold values for x-sampling (DTUNUC 1.x)
13825       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13826      &                SSMIMQ,VVMTHR
13827
13828 * various options for treatment of partons (DTUNUC 1.x)
13829 * (chain recombination, Cronin,..)
13830       LOGICAL LCO2CR,LINTPT
13831       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13832      &                LCO2CR,LINTPT
13833
13834       PARAMETER ( MAXNCL = 260,
13835
13836      &            MAXVQU = MAXNCL,
13837      &            MAXSQU = 20*MAXVQU,
13838      &            MAXINT = MAXVQU+MAXSQU)
13839
13840 * x-values of partons (DTUNUC 1.x)
13841       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13842      &                XTVQ(MAXVQU),XTVD(MAXVQU),
13843      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
13844      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
13845
13846 * flavors of partons (DTUNUC 1.x)
13847       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13848      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13849      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
13850      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13851      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
13852      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13853      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
13854
13855 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13856       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13857      &                IXPV,IXPS,IXTV,IXTS,
13858      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
13859      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
13860      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
13861      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
13862      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
13863      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
13864      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
13865      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
13866
13867 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13868       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13869      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13870
13871 * auxiliary common for chain system storage (DTUNUC 1.x)
13872       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13873
13874       IREJ = 0
13875 *  threshold-x for valence diquarks
13876       XDTHR = CDQ/ECM
13877
13878       GOTO (1,2,3,4) MODE
13879
13880 *---------------------------------------------------------------------
13881 * proj. valence partons - targ. sea partons
13882 * get x-values and flavors for target sea-diquark pair
13883
13884     1 CONTINUE
13885       IDXVP = IDX1
13886       IDXST = IDX2
13887
13888 *  index of corr. val-diquark-x in target nucleon
13889       IDXVT = ITOVT(IFROST(IDXST))
13890 *  available x above diquark thresholds for valence- and sea-diquarks
13891       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13892
13893       IF (XXD.GE.ZERO) THEN
13894 *  x-values for the three diquarks of the target nucleon
13895          RR1    = DT_RNDM(XXD)
13896          RR2    = DT_RNDM(RR1)
13897          RR3    = DT_RNDM(RR2)
13898          SR123  = RR1+RR2+RR3
13899          XXTV   = XDTHR+RR1*XXD/SR123
13900          XXTSQ  = XDTHR+RR2*XXD/SR123
13901          XXTSAQ = XDTHR+RR3*XXD/SR123
13902       ELSE
13903          XXTV   = XTVD(IDXVT)
13904          XXTSQ  = XTSQ(IDXST)
13905          XXTSAQ = XTSAQ(IDXST)
13906       ENDIF
13907 *  flavor of the second quarks in the sea-diquark pair
13908       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13909       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13910 *  check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13911       AM1    = XXTSQ *XPVQ(IDXVP)*ECM**2
13912       AM2    = XXTSAQ*XPVD(IDXVP)*ECM**2
13913       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13914 *    ss-asas pair
13915      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13916          IREJ = 1
13917          RETURN
13918       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13919 *    at least one strange quark
13920      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13921          IREJ = 1
13922          RETURN
13923       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13924          IREJ = 1
13925          RETURN
13926       ENDIF
13927 *  accept the new sea-diquark
13928       XTVD(IDXVT)   = XXTV
13929       XTSQ(IDXST)   = XXTSQ
13930       XTSAQ(IDXST)  = XXTSAQ
13931       NVD           = NVD+1
13932       INTVD1(NVD)   = IDXVP
13933       INTVD2(NVD)   = IDXST
13934       ISKPCH(7,NVD) = 0
13935       RETURN
13936
13937 *---------------------------------------------------------------------
13938 * proj. sea partons - targ. valence partons
13939 * get x-values and flavors for projectile sea-diquark pair
13940
13941     2 CONTINUE
13942       IDXSP = IDX2
13943       IDXVT = IDX1
13944
13945 *  index of corr. val-diquark-x in projectile nucleon
13946       IDXVP = ITOVP(IFROSP(IDXSP))
13947 *  available x above diquark thresholds for valence- and sea-diquarks
13948       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13949
13950       IF (XXD.GE.ZERO) THEN
13951 *  x-values for the three diquarks of the projectile nucleon
13952          RR1    = DT_RNDM(XXD)
13953          RR2    = DT_RNDM(RR1)
13954          RR3    = DT_RNDM(RR2)
13955          SR123  = RR1+RR2+RR3
13956          XXPV   = XDTHR+RR1*XXD/SR123
13957          XXPSQ  = XDTHR+RR2*XXD/SR123
13958          XXPSAQ = XDTHR+RR3*XXD/SR123
13959       ELSE
13960          XXPV   = XPVD(IDXVP)
13961          XXPSQ  = XPSQ(IDXSP)
13962          XXPSAQ = XPSAQ(IDXSP)
13963       ENDIF
13964 *  flavor of the second quarks in the sea-diquark pair
13965       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13966       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13967 *  check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13968       AM1    = XXPSQ *XTVQ(IDXVT)*ECM**2
13969       AM2    = XXPSAQ*XTVD(IDXVT)*ECM**2
13970       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13971 *    ss-asas pair
13972      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13973          IREJ = 1
13974          RETURN
13975       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13976 *    at least one strange quark
13977      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13978          IREJ = 1
13979          RETURN
13980       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13981          IREJ = 1
13982          RETURN
13983       ENDIF
13984 *  accept the new sea-diquark
13985       XPVD(IDXVP)   = XXPV
13986       XPSQ(IDXSP)   = XXPSQ
13987       XPSAQ(IDXSP)  = XXPSAQ
13988       NDV           = NDV+1
13989       INTDV1(NDV)   = IDXSP
13990       INTDV2(NDV)   = IDXVT
13991       ISKPCH(5,NDV) = 0
13992       RETURN
13993
13994 *---------------------------------------------------------------------
13995 * proj. sea partons - targ. sea partons
13996 * get x-values and flavors for target sea-diquark pair
13997
13998     3 CONTINUE
13999       IDXSP = IDX1
14000       IDXST = IDX2
14001
14002 *  index of corr. val-diquark-x in target nucleon
14003       IDXVT = ITOVT(IFROST(IDXST))
14004 *  available x above diquark thresholds for valence- and sea-diquarks
14005       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
14006
14007       IF (XXD.GE.ZERO) THEN
14008 *  x-values for the three diquarks of the target nucleon
14009          RR1    = DT_RNDM(XXD)
14010          RR2    = DT_RNDM(RR1)
14011          RR3    = DT_RNDM(RR2)
14012          SR123  = RR1+RR2+RR3
14013          XXTV   = XDTHR+RR1*XXD/SR123
14014          XXTSQ  = XDTHR+RR2*XXD/SR123
14015          XXTSAQ = XDTHR+RR3*XXD/SR123
14016       ELSE
14017          XXTV   = XTVD(IDXVT)
14018          XXTSQ  = XTSQ(IDXST)
14019          XXTSAQ = XTSAQ(IDXST)
14020       ENDIF
14021 *  flavor of the second quarks in the sea-diquark pair
14022       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
14023       ITSAQ2(IDXST) = -ITSQ2(IDXST)
14024 *  check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
14025       AM1    = XXTSQ *XPSQ(IDXSP)*ECM**2
14026       AM2    = XXTSAQ*XPSAQ(IDXSP)*ECM**2
14027       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
14028 *    ss-asas pair
14029      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
14030          IREJ = 1
14031          RETURN
14032       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
14033 *    at least one strange quark
14034      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
14035          IREJ = 1
14036          RETURN
14037       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14038          IREJ = 1
14039          RETURN
14040       ENDIF
14041 *  accept the new sea-diquark
14042       XTVD(IDXVT)   = XXTV
14043       XTSQ(IDXST)   = XXTSQ
14044       XTSAQ(IDXST)  = XXTSAQ
14045       NSD           = NSD+1
14046       INTSD1(NSD)   = IDXSP
14047       INTSD2(NSD)   = IDXST
14048       ISKPCH(3,NSD) = 0
14049       RETURN
14050
14051 *---------------------------------------------------------------------
14052 * proj. sea partons - targ. sea partons
14053 * get x-values and flavors for projectile sea-diquark pair
14054
14055     4 CONTINUE
14056       IDXSP = IDX2
14057       IDXST = IDX1
14058
14059 *  index of corr. val-diquark-x in projectile nucleon
14060       IDXVP = ITOVP(IFROSP(IDXSP))
14061 *  available x above diquark thresholds for valence- and sea-diquarks
14062       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
14063
14064       IF (XXD.GE.ZERO) THEN
14065 *  x-values for the three diquarks of the projectile nucleon
14066          RR1    = DT_RNDM(XXD)
14067          RR2    = DT_RNDM(RR1)
14068          RR3    = DT_RNDM(RR2)
14069          SR123  = RR1+RR2+RR3
14070          XXPV   = XDTHR+RR1*XXD/SR123
14071          XXPSQ  = XDTHR+RR2*XXD/SR123
14072          XXPSAQ = XDTHR+RR3*XXD/SR123
14073       ELSE
14074          XXPV   = XPVD(IDXVP)
14075          XXPSQ  = XPSQ(IDXSP)
14076          XXPSAQ = XPSAQ(IDXSP)
14077       ENDIF
14078 *  flavor of the second quarks in the sea-diquark pair
14079       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
14080       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
14081 *  check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
14082       AM1    = XXPSQ *XTSQ(IDXST)*ECM**2
14083       AM2    = XXPSAQ*XTSAQ(IDXST)*ECM**2
14084       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
14085 *    ss-asas pair
14086      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
14087          IREJ = 1
14088          RETURN
14089       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
14090 *    at least one strange quark
14091      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
14092          IREJ = 1
14093          RETURN
14094       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14095          IREJ = 1
14096          RETURN
14097       ENDIF
14098 *  accept the new sea-diquark
14099       XPVD(IDXVP)   = XXPV
14100       XPSQ(IDXSP)   = XXPSQ
14101       XPSAQ(IDXSP)  = XXPSAQ
14102       NDS           = NDS+1
14103       INTDS1(NDS)   = IDXSP
14104       INTDS2(NDS)   = IDXST
14105       ISKPCH(2,NDS) = 0
14106       RETURN
14107       END
14108 *$ CREATE DT_DIFEVT.FOR
14109 *COPY DT_DIFEVT
14110 *
14111 *===difevt=============================================================*
14112 *
14113       SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
14114      &                  IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
14115
14116 ************************************************************************
14117 * Interface to treatment of diffractive interactions.                  *
14118 *  (input)          IFP1/2        PDG-indizes of projectile partons    *
14119 *                                 (baryon: IFP2 - adiquark)            *
14120 *                   PP(4)         projectile 4-momentum                *
14121 *                   IFT1/2        PDG-indizes of target partons        *
14122 *                                 (baryon: IFT1 - adiquark)            *
14123 *                   PT(4)         target 4-momentum                    *
14124 *  (output)         JDIFF = 0     no diffraction                       *
14125 *                         = 1/-1  LMSD/LMDD                            *
14126 *                         = 2/-2  HMSD/HMDD                            *
14127 *                   NCSY          counter for two-chain systems        *
14128 *                                 dumped to DTEVT1                     *
14129 * This version dated 14.02.95 is written by S. Roesler                 *
14130 ************************************************************************
14131
14132       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14133       SAVE
14134
14135       PARAMETER ( LINP = 10 ,
14136      &            LOUT = 6 ,
14137      &            LDAT = 9 )
14138
14139       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
14140      &           OHALF=0.5D0)
14141
14142 * event history
14143
14144       PARAMETER (NMXHKK=200000)
14145
14146       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14147      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14148      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14149
14150 * extended event history
14151       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14152      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14153      &                IHIST(2,NMXHKK)
14154
14155 * flags for diffractive interactions (DTUNUC 1.x)
14156       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14157
14158       DIMENSION PP(4),PT(4)
14159
14160       LOGICAL LFIRST
14161       DATA LFIRST /.TRUE./
14162
14163       IREJ   = 0
14164       JDIFF  = 0
14165       IFLAGD = JDIFF
14166
14167 * cm. energy
14168       XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
14169      &          (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
14170 * identities of projectile hadron / target nucleon
14171       KPROJ = IDT_ICIHAD(IDHKK(MOP))
14172       KTARG = IDT_ICIHAD(IDHKK(MOT))
14173
14174 * single diffractive xsections
14175       CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
14176 * double diffractive xsections
14177 **!! no double diff yet
14178 C     CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
14179       DDTOT = 0.0D0
14180       DDHM  = 0.0D0
14181 **!!
14182 * total inelastic xsection
14183 C     SIGIN  = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
14184       DUMZER = ZERO
14185       CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
14186       SIGIN  = MAX(SIGTO-SIGEL,ZERO)
14187
14188 * fraction of diffractive processes
14189       FRADIF = (SDTOT+DDTOT)/SIGIN
14190
14191       IF (LFIRST) THEN
14192          WRITE(LOUT,1000) XM,SDTOT,SIGIN
14193  1000    FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
14194      &          F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
14195      &          F5.1,' mb',/)
14196          LFIRST = .FALSE.
14197       ENDIF
14198
14199       IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
14200      &    (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
14201 * diffractive interaction requested by x-section or by user
14202          FRASD  = SDTOT/(SDTOT+DDTOT)
14203          FRASDH = SDHM/SDTOT
14204 **sr needs to be specified!!
14205 C        FRADDH = DDHM/DDTOT
14206          FRADDH = 1.0D0
14207 **
14208          IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
14209 *   single diffraction
14210             KDIFF = 1
14211             IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
14212                KP = 2
14213                KT = 0
14214                IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
14215      &               ISINGD.NE.3) THEN
14216                   KP = 0
14217                   KT = 2
14218                ENDIF
14219             ELSE
14220                KP = 1
14221                KT = 0
14222                IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
14223      &               ISINGD.NE.3) THEN
14224                   KP = 0
14225                   KT = 1
14226                ENDIF
14227             ENDIF
14228          ELSE
14229 *   double diffraction
14230             KDIFF = -1
14231             IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
14232                KP = 2
14233                KT = 2
14234             ELSE
14235                KP = 1
14236                KT = 1
14237             ENDIF
14238          ENDIF
14239          CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14240      &               IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14241          IF (IREJ1.EQ.0) THEN
14242             IFLAGD = 2*KDIFF
14243             IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
14244          ELSE
14245             GOTO 9999
14246          ENDIF
14247       ENDIF
14248       JDIFF = IFLAGD
14249
14250       RETURN
14251
14252  9999 CONTINUE
14253       IREJ  = 1
14254       RETURN
14255       END
14256
14257 *$ CREATE DT_DIFFKI.FOR
14258 *COPY DT_DIFFKI
14259 *
14260 *===difkin=============================================================*
14261 *
14262       SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14263      &                  IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
14264
14265 ************************************************************************
14266 * Kinematics of diffractive nucleon-nucleon interaction.               *
14267 *          IFP1/2   PDG-indizes of projectile partons                  *
14268 *                   (baryon: IFP2 - adiquark)                          *
14269 *          PP(4)    projectile 4-momentum                              *
14270 *          IFT1/2   PDG-indizes of target partons                      *
14271 *                   (baryon: IFT1 - adiquark)                          *
14272 *          PT(4)    target 4-momentum                                  *
14273 *          KP   = 0 projectile quasi-elastically scattered             *
14274 *               = 1            excited to low-mass diff. state         *
14275 *               = 2            excited to high-mass diff. state        *
14276 *          KT   = 0 target     quasi-elastically scattered             *
14277 *               = 1            excited to low-mass diff. state         *
14278 *               = 2            excited to high-mass diff. state        *
14279 * This version dated 12.02.95 is written by S. Roesler                 *
14280 ************************************************************************
14281
14282       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14283       SAVE
14284
14285       PARAMETER ( LINP = 10 ,
14286      &            LOUT = 6 ,
14287      &            LDAT = 9 )
14288
14289       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
14290
14291       LOGICAL LSTART
14292
14293 * particle properties (BAMJET index convention)
14294       CHARACTER*8  ANAME
14295       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14296      &                IICH(210),IIBAR(210),K1(210),K2(210)
14297
14298 * flags for input different options
14299       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14300       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14301      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14302
14303 * rejection counter
14304       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14305      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14306      &                IREXCI(3),IRDIFF(2),IRINC
14307
14308 * kinematics of diffractive interactions (DTUNUC 1.x)
14309       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14310      &                PPF(4),PTF(4),
14311      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14312      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14313
14314       DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
14315      &          PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
14316
14317       DATA LSTART /.TRUE./
14318
14319       IF (LSTART) THEN
14320          WRITE(LOUT,2000)
14321  2000    FORMAT(/,1X,'DIFEVT:  diffractive interactions treated ')
14322          LSTART = .FALSE.
14323       ENDIF
14324
14325       IREJ = 0
14326
14327 * initialize common /DTDIKI/
14328       CALL DT_DIFINI
14329 * store momenta of initial incoming particles for emc-check
14330       IF (LEMCCK) THEN
14331          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
14332          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
14333       ENDIF
14334
14335 * masses of initial particles
14336       XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
14337       XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
14338       IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
14339       XMP  = SQRT(XMP2)
14340       XMT  = SQRT(XMT2)
14341 * check quark-input (used to adjust coherence cond. for M-selection)
14342       IBP  = 0
14343       IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
14344       IBT  = 0
14345       IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
14346
14347 * parameter for Lorentz-transformation into nucleon-nucleon cms
14348       DO 3 K=1,4
14349          PITOT(K) = PP(K)+PT(K)
14350     3 CONTINUE
14351       XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
14352       IF (XMTOT2.LE.ZERO) THEN
14353          WRITE(LOUT,1000) XMTOT2
14354  1000    FORMAT(1X,'DIFEVT:   negative cm. energy!  ',
14355      &          'XMTOT2 = ',E12.3)
14356          GOTO 9999
14357       ENDIF
14358       XMTOT = SQRT(XMTOT2)
14359       DO 4 K=1,4
14360          BGTOT(K) = PITOT(K)/XMTOT
14361     4 CONTINUE
14362 * transformation of nucleons into cms
14363       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
14364      &            PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
14365       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
14366      &            PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
14367 * rotation angles
14368       COD = PP1(3)/PPTOT
14369 C     SID = SQRT((ONE-COD)*(ONE+COD))
14370       PPT = SQRT(PP1(1)**2+PP1(2)**2)
14371       SID = PPT/PPTOT
14372       COF = ONE
14373       SIF = ZERO
14374       IF(PPTOT*SID.GT.TINY10) THEN
14375          COF   = PP1(1)/(SID*PPTOT)
14376          SIF   = PP1(2)/(SID*PPTOT)
14377          ANORF = SQRT(COF*COF+SIF*SIF)
14378          COF   = COF/ANORF
14379          SIF   = SIF/ANORF
14380       ENDIF
14381 * check consistency
14382       DO 5 K=1,4
14383          DEV1(K) = ABS(PP1(K)+PT1(K))
14384     5 CONTINUE
14385       DEV1(4) = ABS(DEV1(4)-XMTOT)
14386       IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
14387      &    (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10))     THEN
14388          WRITE(LOUT,1001) DEV1
14389  1001    FORMAT(1X,'DIFEVT:   inconsitent Lorentz-transformation! ',
14390      &          /,8X,4E12.3)
14391          GOTO 9999
14392       ENDIF
14393
14394 * select x-fractions in high-mass diff. interactions
14395       IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
14396
14397 * select diffractive masses
14398 * - projectile
14399       IF (KP.EQ.1) THEN
14400          XMPF = DT_XMLMD(XMTOT)
14401          CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
14402          IF (IREJ1.GT.0) GOTO 9999
14403       ELSEIF (KP.EQ.2) THEN
14404          XMPF = DT_XMHMD(XMTOT,IBP,1)
14405       ELSE
14406          XMPF = XMP
14407       ENDIF
14408 * - target
14409       IF (KT.EQ.1) THEN
14410          XMTF = DT_XMLMD(XMTOT)
14411          CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
14412          IF (IREJ1.GT.0) GOTO 9999
14413       ELSEIF (KT.EQ.2) THEN
14414          XMTF = DT_XMHMD(XMTOT,IBT,2)
14415       ELSE
14416          XMTF = XMT
14417       ENDIF
14418
14419 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
14420       XMPF2 = XMPF**2
14421       XMTF2 = XMTF**2
14422       PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
14423       PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
14424
14425 * select momentum transfer (all t-values used here are <0)
14426 *   minimum absolute value to produce diffractive masses
14427       TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
14428       TT   = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
14429       IF (IREJ1.GT.0) GOTO 9999
14430
14431 * longitudinal momentum of excited/elastically scattered projectile
14432       PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
14433 * total transverse momentum due to t-selection
14434       PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
14435       IF (PPBLT2.LT.ZERO) THEN
14436          WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
14437  1002    FORMAT(1X,'DIFEVT:   inconsistent transverse momentum! ',
14438      &          E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
14439          GOTO 9999
14440       ENDIF
14441       CALL DT_DSFECF(SINPHI,COSPHI)
14442       PPBLT     = SQRT(PPBLT2)
14443       PPBLOB(1) = COSPHI*PPBLT
14444       PPBLOB(2) = SINPHI*PPBLT
14445
14446 * rotate excited/elastically scattered projectile into n-n cms.
14447       CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
14448      &                                                    XX,YY,ZZ)
14449       PPBLOB(1) = XX
14450       PPBLOB(2) = YY
14451       PPBLOB(3) = ZZ
14452
14453 * 4-momentum of excited/elastically scattered target and of exchanged
14454 * Pomeron
14455       DO 6 K=1,4
14456          IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
14457          PPOM1(K) = PP1(K)-PPBLOB(K)
14458     6 CONTINUE
14459       PTBLOB(4) = XMTOT-PPBLOB(4)
14460
14461 * Lorentz-transformation back into system of initial diff. collision
14462       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14463      &            PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
14464      &            PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
14465       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14466      &            PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
14467      &            PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
14468       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14469      &            PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
14470      &            PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
14471
14472 * store 4-momentum of elastically scattered particle (in single diff.
14473 * events)
14474       IF (KP.EQ.0) THEN
14475          DO 7 K=1,4
14476             PSC(K) = PPF(K)
14477     7    CONTINUE
14478       ELSEIF (KT.EQ.0) THEN
14479          DO 8 K=1,4
14480             PSC(K) = PTF(K)
14481     8    CONTINUE
14482       ENDIF
14483
14484 * check consistency of kinematical treatment so far
14485       IF (LEMCCK) THEN
14486          CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
14487          CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
14488          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
14489          IF (IREJ1.NE.0) GOTO 9999
14490       ENDIF
14491       DO 9 K=1,4
14492          DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
14493          DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
14494     9 CONTINUE
14495       IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
14496      &    (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
14497      &    (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
14498      &    (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5))     THEN
14499          WRITE(LOUT,1003) DEV1,DEV2
14500  1003    FORMAT(1X,'DIFEVT:   inconsitent kinematical treatment!  ',
14501      &          2(/,8X,4E12.3))
14502          GOTO 9999
14503       ENDIF
14504
14505 * kinematical treatment for low-mass diffraction
14506       CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
14507       IF (IREJ1.NE.0) GOTO 9999
14508
14509 * dump diffractive chains into DTEVT1
14510       CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14511       IF (IREJ1.NE.0) GOTO 9999
14512
14513       RETURN
14514
14515  9999 CONTINUE
14516       IRDIFF(1) = IRDIFF(1)+1
14517       IREJ      = 1
14518       RETURN
14519       END
14520
14521 *$ CREATE DT_XMHMD.FOR
14522 *COPY DT_XMHMD
14523 *
14524 *===xmhmd==============================================================*
14525 *
14526       DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
14527
14528 ************************************************************************
14529 * Diffractive mass in high mass single/double diffractive events.      *
14530 * This version dated 11.02.95 is written by S. Roesler                 *
14531 ************************************************************************
14532
14533       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14534       SAVE
14535
14536       PARAMETER ( LINP = 10 ,
14537      &            LOUT = 6 ,
14538      &            LDAT = 9 )
14539
14540       PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
14541
14542 * kinematics of diffractive interactions (DTUNUC 1.x)
14543       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14544      &                PPF(4),PTF(4),
14545      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14546      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14547
14548 C     DATA XCOLOW /0.05D0/
14549       DATA XCOLOW /0.15D0/
14550
14551       DT_XMHMD = ZERO
14552       XH = XPH(2)
14553       IF (MODE.EQ.2) XH = XTH(2)
14554
14555 * minimum Pomeron-x for high-mass diffraction
14556 * (adjusted to get a smooth transition between HM and LM component)
14557       R = DT_RNDM(XH)
14558       XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
14559       IF (ECM.LE.300.0D0) THEN
14560          RR     = (1.0D0-EXP(-((ECM/140.0D0)**4)))
14561          XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
14562       ENDIF
14563 * maximum Pomeron-x for high-mass diffraction
14564 * (coherence condition, adjusted to fit to experimental data)
14565       IF (IB.NE.0) THEN
14566 *   baryon-diffraction
14567          XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
14568       ELSE
14569 *   meson-diffraction
14570          XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
14571       ENDIF
14572 * check boundaries
14573       IF (XDIMIN.GE.XDIMAX) THEN
14574          XDIMIN = OHALF*XDIMAX
14575       ENDIF
14576
14577       KLOOP = 0
14578     1 CONTINUE
14579       KLOOP = KLOOP+1
14580       IF (KLOOP.GT.20) RETURN
14581 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
14582       XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
14583 * corr. diffr. mass
14584       DT_XMHMD = ECM*SQRT(XDIFF)
14585       IF (DT_XMHMD.LT.2.5D0) GOTO 1
14586
14587       RETURN
14588       END
14589
14590 *$ CREATE DT_XMLMD.FOR
14591 *COPY DT_XMLMD
14592 *
14593 *===xmlmd==============================================================*
14594 *
14595       DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
14596
14597 ************************************************************************
14598 * Diffractive mass in high mass single/double diffractive events.      *
14599 * This version dated 11.02.95 is written by S. Roesler                 *
14600 ************************************************************************
14601
14602       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14603       SAVE
14604
14605       PARAMETER ( LINP = 10 ,
14606      &            LOUT = 6 ,
14607      &            LDAT = 9 )
14608
14609 * minimum Pomeron-x for low-mass diffraction
14610 C     AMO = 1.5D0
14611       AMO = 2.0D0
14612 * maximum Pomeron-x for low-mass diffraction
14613 * (adjusted to get a smooth transition between HM and LM component)
14614       R   = DT_RNDM(AMO)
14615       SAM = 1.0D0
14616       IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
14617       R   = DT_RNDM(AMO)*SAM
14618       AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
14619       AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
14620
14621 * selection of diffractive mass
14622 * (adjusted to get a smooth transition between HM and LM component)
14623       R   = DT_RNDM(AMU)
14624       IF (ECM.LE.50.0D0) THEN
14625          DT_XMLMD = AMO*(AMU/AMO)**R
14626       ELSE
14627          A = 0.7D0
14628          IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
14629          DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
14630       ENDIF
14631
14632       RETURN
14633       END
14634
14635 *$ CREATE DT_TDIFF.FOR
14636 *COPY DT_TDIFF
14637 *
14638 *===tdiff==============================================================*
14639 *
14640       DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14641
14642 ************************************************************************
14643 * t-selection for single/double diffractive interactions.              *
14644 *          ECM      cm. energy                                         *
14645 *          TMIN     minimum momentum transfer to produce diff. masses  *
14646 *          XM1/XM2  diffractively produced masses                      *
14647 *                   (for single diffraction XM2 is obsolete)           *
14648 *          K1/K2= 0 not excited                                        *
14649 *               = 1 low-mass excitation                                *
14650 *               = 2 high-mass excitation                               *
14651 * This version dated 11.02.95 is written by S. Roesler                 *
14652 ************************************************************************
14653
14654       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14655       SAVE
14656
14657       PARAMETER ( LINP = 10 ,
14658      &            LOUT = 6 ,
14659      &            LDAT = 9 )
14660
14661       PARAMETER (ZERO=0.0D0)
14662
14663       PARAMETER ( BTP0   = 3.7D0,
14664      &            ALPHAP = 0.24D0 )
14665
14666       IREJ   = 0
14667       NCLOOP = 0
14668       DT_TDIFF  = ZERO
14669
14670       IF (K1.GT.0) THEN
14671          XM1 = XM1I
14672          XM2 = XM2I
14673       ELSE
14674          XM1 = XM2I
14675       ENDIF
14676       XDI = (XM1/ECM)**2
14677       IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14678 * slope for single diffraction
14679          SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14680       ELSE
14681 * slope for double diffraction
14682          SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14683       ENDIF
14684
14685     1 CONTINUE
14686       NCLOOP = NCLOOP+1
14687       IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14688       Y = DT_RNDM(XDI)
14689       T = -LOG(1.0D0-Y)/SLOPE
14690       IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14691       DT_TDIFF = -ABS(T)
14692
14693       RETURN
14694
14695  9999 CONTINUE
14696       WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14697  1000 FORMAT(1X,'DT_TDIFF:   t-selection rejected!',/,
14698      &       1X,'ECM  = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14699      &       E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14700       IREJ = 1
14701       RETURN
14702       END
14703
14704 *$ CREATE DT_XVALHM.FOR
14705 *COPY DT_XVALHM
14706 *
14707 *===xvalhm=============================================================*
14708 *
14709       SUBROUTINE DT_XVALHM(KP,KT)
14710
14711 ************************************************************************
14712 * Sampling of parton x-values in high-mass diffractive interactions.   *
14713 * This version dated 12.02.95 is written by S. Roesler                 *
14714 ************************************************************************
14715
14716       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14717       SAVE
14718
14719       PARAMETER ( LINP = 10 ,
14720      &            LOUT = 6 ,
14721      &            LDAT = 9 )
14722
14723       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14724
14725 * kinematics of diffractive interactions (DTUNUC 1.x)
14726       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14727      &                PPF(4),PTF(4),
14728      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14729      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14730
14731 * various options for treatment of partons (DTUNUC 1.x)
14732 * (chain recombination, Cronin,..)
14733       LOGICAL LCO2CR,LINTPT
14734       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14735      &                LCO2CR,LINTPT
14736
14737       DATA UNON,XVQTHR /2.0D0,0.8D0/
14738
14739       IF (KP.EQ.2) THEN
14740 * x-fractions of projectile valence partons
14741     1    CONTINUE
14742          XPH(1) = DT_DBETAR(OHALF,UNON)
14743          IF (XPH(1).GE.XVQTHR) GOTO 1
14744          XPH(2) = ONE-XPH(1)
14745 * x-fractions of Pomeron q-aq-pair
14746          XPOLO = TINY2
14747          XPOHI = ONE-TINY2
14748          XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14749          XPPO(2) = ONE-XPPO(1)
14750 * flavors of Pomeron q-aq-pair
14751          IFLAV    = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14752          IFPPO(1) = IFLAV
14753          IFPPO(2) = -IFLAV
14754          IF (DT_RNDM(UNON).GT.OHALF) THEN
14755             IFPPO(1) = -IFLAV
14756             IFPPO(2) = IFLAV
14757          ENDIF
14758       ENDIF
14759
14760       IF (KT.EQ.2) THEN
14761 * x-fractions of projectile target partons
14762     2    CONTINUE
14763          XTH(1) = DT_DBETAR(OHALF,UNON)
14764          IF (XTH(1).GE.XVQTHR) GOTO 2
14765          XTH(2) = ONE-XTH(1)
14766 * x-fractions of Pomeron q-aq-pair
14767          XPOLO = TINY2
14768          XPOHI = ONE-TINY2
14769          XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14770          XTPO(2) = ONE-XTPO(1)
14771 * flavors of Pomeron q-aq-pair
14772          IFLAV    = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14773          IFTPO(1) = IFLAV
14774          IFTPO(2) = -IFLAV
14775          IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14776             IFTPO(1) = -IFLAV
14777             IFTPO(2) = IFLAV
14778          ENDIF
14779       ENDIF
14780
14781       RETURN
14782       END
14783
14784 *$ CREATE DT_LM2RES.FOR
14785 *COPY DT_LM2RES
14786 *
14787 *===lm2res=============================================================*
14788 *
14789       SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14790
14791 ************************************************************************
14792 * Check low-mass diffractive excitation for resonance mass.            *
14793 *   (input)   IF1/2    PDG-indizes of valence partons                  *
14794 *   (in/out)  XM       diffractive mass requested/corrected            *
14795 *   (output)  IDR/IDXR id./BAMJET-index of resonance                   *
14796 * This version dated 12.02.95 is written by S. Roesler                 *
14797 ************************************************************************
14798
14799       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14800       SAVE
14801
14802       PARAMETER ( LINP = 10 ,
14803      &            LOUT = 6 ,
14804      &            LDAT = 9 )
14805
14806       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14807
14808 * kinematics of diffractive interactions (DTUNUC 1.x)
14809       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14810      &                PPF(4),PTF(4),
14811      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14812      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14813
14814       IREJ = 0
14815       IF1B = 0
14816       IF2B = 0
14817       XMI  = XM
14818
14819 * BAMJET indices of partons
14820       IF1A = IDT_IPDG2B(IF1,1,2)
14821       IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14822       IF2A = IDT_IPDG2B(IF2,1,2)
14823       IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14824
14825 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14826       IDCH = 2
14827       IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14828
14829 * check for resonance mass
14830       CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14831       IF (IREJ1.NE.0) GOTO 9999
14832
14833       XM = XMN
14834       RETURN
14835
14836  9999 CONTINUE
14837       IREJ = 1
14838       RETURN
14839       END
14840
14841 *$ CREATE DT_LMKINE.FOR
14842 *COPY DT_LMKINE
14843 *
14844 *===lmkine=============================================================*
14845 *
14846       SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14847
14848 ************************************************************************
14849 * Kinematical treatment of low-mass excitations.                       *
14850 * This version dated 12.02.95 is written by S. Roesler                 *
14851 ************************************************************************
14852
14853       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14854       SAVE
14855
14856       PARAMETER ( LINP = 10 ,
14857      &            LOUT = 6 ,
14858      &            LDAT = 9 )
14859
14860       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14861
14862 * flags for input different options
14863       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14864       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14865      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14866
14867 * kinematics of diffractive interactions (DTUNUC 1.x)
14868       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14869      &                PPF(4),PTF(4),
14870      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14871      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14872
14873       DIMENSION P1(4),P2(4)
14874
14875       IREJ = 0
14876
14877       IF (KP.EQ.1) THEN
14878          PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14879          POE  = PPF(4)/PABS
14880          FAC1 = OHALF*(POE+ONE)
14881          FAC2 = -OHALF*(POE-ONE)
14882          DO 1 K=1,3
14883             PPLM1(K) = FAC1*PPF(K)
14884             PPLM2(K) = FAC2*PPF(K)
14885     1    CONTINUE
14886          PPLM1(4) = FAC1*PABS
14887          PPLM2(4) = -FAC2*PABS
14888          IF (IMSHL.EQ.1) THEN
14889
14890             XM1 = PYMASS(IFP1)
14891             XM2 = PYMASS(IFP2)
14892
14893             CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14894             IF (IREJ1.NE.0) GOTO 9999
14895             DO 2 K=1,4
14896                PPLM1(K) = P1(K)
14897                PPLM2(K) = P2(K)
14898     2       CONTINUE
14899          ENDIF
14900       ENDIF
14901
14902       IF (KT.EQ.1) THEN
14903          PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14904          POE  = PTF(4)/PABS
14905          FAC1 = OHALF*(POE+ONE)
14906          FAC2 = -OHALF*(POE-ONE)
14907          DO 3 K=1,3
14908             PTLM2(K) = FAC1*PTF(K)
14909             PTLM1(K) = FAC2*PTF(K)
14910     3    CONTINUE
14911          PTLM2(4) = FAC1*PABS
14912          PTLM1(4) = -FAC2*PABS
14913          IF (IMSHL.EQ.1) THEN
14914
14915             XM1 = PYMASS(IFT1)
14916             XM2 = PYMASS(IFT2)
14917
14918             CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14919             IF (IREJ1.NE.0) GOTO 9999
14920             DO 4 K=1,4
14921                PTLM1(K) = P1(K)
14922                PTLM2(K) = P2(K)
14923     4       CONTINUE
14924          ENDIF
14925       ENDIF
14926
14927       RETURN
14928
14929  9999 CONTINUE
14930       WRITE(LOUT,'(A)') 'LMKINE:   kinematical treatment rejected'
14931       IREJ = 1
14932       RETURN
14933       END
14934
14935 *$ CREATE DT_DIFINI.FOR
14936 *COPY DT_DIFINI
14937 *
14938 *===difini=============================================================*
14939 *
14940       SUBROUTINE DT_DIFINI
14941
14942 ************************************************************************
14943 * Initialization of common /DTDIKI/                                    *
14944 * This version dated 12.02.95 is written by S. Roesler                 *
14945 ************************************************************************
14946
14947       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14948       SAVE
14949
14950       PARAMETER ( LINP = 10 ,
14951      &            LOUT = 6 ,
14952      &            LDAT = 9 )
14953
14954       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14955
14956 * kinematics of diffractive interactions (DTUNUC 1.x)
14957       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14958      &                PPF(4),PTF(4),
14959      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14960      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14961
14962       DO 1 K=1,4
14963          PPOM(K)  = ZERO
14964          PSC(K)   = ZERO
14965          PPF(K)   = ZERO
14966          PTF(K)   = ZERO
14967          PPLM1(K) = ZERO
14968          PPLM2(K) = ZERO
14969          PTLM1(K) = ZERO
14970          PTLM2(K) = ZERO
14971     1 CONTINUE
14972       DO 2 K=1,2
14973          XPH(K)   = ZERO
14974          XPPO(K)  = ZERO
14975          XTH(K)   = ZERO
14976          XTPO(K)  = ZERO
14977          IFPPO(K) = 0
14978          IFTPO(K) = 0
14979     2 CONTINUE
14980       IDPR  = 0
14981       IDXPR = 0
14982       IDTR  = 0
14983       IDXTR = 0
14984
14985       RETURN
14986       END
14987
14988 *$ CREATE DT_DIFPUT.FOR
14989 *COPY DT_DIFPUT
14990 *
14991 *===difput=============================================================*
14992 *
14993       SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14994      &                                                          IREJ)
14995
14996 ************************************************************************
14997 * Dump diffractive chains into DTEVT1                                  *
14998 * This version dated 12.02.95 is written by S. Roesler                 *
14999 ************************************************************************
15000
15001       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15002       SAVE
15003
15004       PARAMETER ( LINP = 10 ,
15005      &            LOUT = 6 ,
15006      &            LDAT = 9 )
15007
15008       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
15009
15010       LOGICAL LCHK
15011
15012 * kinematics of diffractive interactions (DTUNUC 1.x)
15013       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
15014      &                PPF(4),PTF(4),
15015      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
15016      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
15017
15018 * event history
15019
15020       PARAMETER (NMXHKK=200000)
15021
15022       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15023      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15024      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15025
15026 * extended event history
15027       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15028      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15029      &                IHIST(2,NMXHKK)
15030
15031 * rejection counter
15032       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
15033      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
15034      &                IREXCI(3),IRDIFF(2),IRINC
15035
15036       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
15037      &          P1(4),P2(4),P3(4),P4(4)
15038
15039       IREJ = 0
15040
15041       IF (KP.EQ.1) THEN
15042          DO 1 K=1,4
15043             PCH(K) = PPLM1(K)+PPLM2(K)
15044     1    CONTINUE
15045          ID1 = IFP1
15046          ID2 = IFP2
15047          IF (DT_RNDM(PT).GT.OHALF) THEN
15048             ID1 = IFP2
15049             ID2 = IFP1
15050          ENDIF
15051          CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
15052      &                                        PPLM1(4),0,0,0)
15053          CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
15054      &                                        PPLM2(4),0,0,0)
15055          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15056      &                                              IDPR,IDXPR,8)
15057       ELSEIF (KP.EQ.2) THEN
15058          DO 2 K=1,4
15059             PP1(K) = XPH(1)*PP(K)
15060             PP2(K) = XPH(2)*PP(K)
15061             PT1(K) = -XPPO(1)*PPOM(K)
15062             PT2(K) = -XPPO(2)*PPOM(K)
15063     2    CONTINUE
15064          CALL  DT_CHKCSY(IFP1,IFPPO(1),LCHK)
15065          XM1 = ZERO
15066          XM2 = ZERO
15067          IF (LCHK) THEN
15068             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15069             IF (IREJ1.NE.0) GOTO 9999
15070             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15071             IF (IREJ1.NE.0) GOTO 9999
15072             DO 3 K=1,4
15073                PP1(K) = P1(K)
15074                PT1(K) = P2(K)
15075                PP2(K) = P3(K)
15076                PT2(K) = P4(K)
15077     3       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(1),MOT,0,PT1(1),PT1(2),PT1(3),
15081      &                                             PT1(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(2),MOT,0,PT2(1),PT2(2),PT2(3),
15085      &                                             PT2(4),0,0,8)
15086          ELSE
15087             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15088             IF (IREJ1.NE.0) GOTO 9999
15089             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15090             IF (IREJ1.NE.0) GOTO 9999
15091             DO 4 K=1,4
15092                PP1(K) = P1(K)
15093                PT2(K) = P2(K)
15094                PP2(K) = P3(K)
15095                PT1(K) = P4(K)
15096     4       CONTINUE
15097             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15098      &                                                       0,0,8)
15099             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15100      &                                                PT2(4),0,0,8)
15101             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15102      &                                                       0,0,8)
15103             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15104      &                                                PT1(4),0,0,8)
15105          ENDIF
15106          NCSY = NCSY+1
15107       ELSE
15108          CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
15109      &                                                        0,0,0)
15110       ENDIF
15111
15112       IF (KT.EQ.1) THEN
15113          DO 5 K=1,4
15114             PCH(K) = PTLM1(K)+PTLM2(K)
15115     5    CONTINUE
15116          ID1 = IFT1
15117          ID2 = IFT2
15118          IF (DT_RNDM(PT).GT.OHALF) THEN
15119             ID1 = IFT2
15120             ID2 = IFT1
15121          ENDIF
15122          CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
15123      &                                              PTLM1(4),0,0,0)
15124          CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
15125      &                                              PTLM2(4),0,0,0)
15126          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15127      &                                              IDTR,IDXTR,8)
15128       ELSEIF (KT.EQ.2) THEN
15129          DO 6 K=1,4
15130             PP1(K) = XTPO(1)*PPOM(K)
15131             PP2(K) = XTPO(2)*PPOM(K)
15132             PT1(K) = XTH(2)*PT(K)
15133             PT2(K) = XTH(1)*PT(K)
15134     6    CONTINUE
15135          CALL  DT_CHKCSY(IFTPO(1),IFT1,LCHK)
15136          XM1 = ZERO
15137          XM2 = ZERO
15138          IF (LCHK) THEN
15139             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15140             IF (IREJ1.NE.0) GOTO 9999
15141             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15142             IF (IREJ1.NE.0) GOTO 9999
15143             DO 7 K=1,4
15144                PP1(K) = P1(K)
15145                PT1(K) = P2(K)
15146                PP2(K) = P3(K)
15147                PT2(K) = P4(K)
15148     7       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,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(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,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15156      &                                                       0,0,8)
15157          ELSE
15158             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15159             IF (IREJ1.NE.0) GOTO 9999
15160             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15161             IF (IREJ1.NE.0) GOTO 9999
15162             DO 8 K=1,4
15163                PP1(K) = P1(K)
15164                PT2(K) = P2(K)
15165                PP2(K) = P3(K)
15166                PT1(K) = P4(K)
15167     8       CONTINUE
15168             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15169      &                                                PP1(4),0,0,8)
15170             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15171      &                                                       0,0,8)
15172             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15173      &                                                PP2(4),0,0,8)
15174             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15175      &                                                       0,0,8)
15176          ENDIF
15177          NCSY = NCSY+1
15178       ELSE
15179          CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
15180      &                                                        0,0,0)
15181       ENDIF
15182
15183       RETURN
15184
15185  9999 CONTINUE
15186       IRDIFF(2) = IRDIFF(2)+1
15187       IREJ      = 1
15188       RETURN
15189       END
15190 *$ CREATE DT_EVTFRG.FOR
15191 *COPY DT_EVTFRG
15192 *
15193 *===evtfrg=============================================================*
15194 *
15195       SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
15196
15197 ************************************************************************
15198 * Hadronization of chains in DTEVT1.                                   *
15199 *                                                                      *
15200 * Input:                                                               *
15201 *   KMODE = 1   hadronization of PHOJET-chains (id=77xxx)              *
15202 *         = 2   hadronization of DTUNUC-chains (id=88xxx)              *
15203 *   NFRG  if KMODE = 1 : upper index of PHOJET-scatterings to be       *
15204 *                        hadronized with one PYEXEC call               *
15205 *         if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
15206 *                        with one PYEXEC call                          *
15207 * Output:                                                              *
15208 *   NPYMEM      number of entries in JETSET-common after hadronization *
15209 *   IREJ        rejection flag                                         *
15210 *                                                                      *
15211 * This version dated 17.09.00 is written by S. Roesler                 *
15212 ************************************************************************
15213
15214       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15215       SAVE
15216
15217       PARAMETER ( LINP = 10 ,
15218      &            LOUT = 6 ,
15219      &            LDAT = 9 )
15220
15221       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
15222       PARAMETER (ONE=1.0D0,ZERO=0.0D0)
15223
15224       LOGICAL LACCEP
15225
15226       PARAMETER (MXJOIN=200)
15227
15228 * event history
15229
15230       PARAMETER (NMXHKK=200000)
15231
15232       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15233      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15234      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15235
15236 * extended event history
15237       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15238      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15239      &                IHIST(2,NMXHKK)
15240
15241 * flags for input different options
15242       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15243       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15244      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15245
15246 * statistics
15247       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
15248      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
15249      &                ICEVTG(8,0:30)
15250
15251 * flags for diffractive interactions (DTUNUC 1.x)
15252       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
15253
15254 * nucleon-nucleon event-generator
15255       CHARACTER*8 CMODEL
15256       LOGICAL LPHOIN
15257       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
15258 * phojet
15259
15260 C  model switches and parameters
15261       CHARACTER*8 MDLNA
15262       INTEGER ISWMDL,IPAMDL
15263       DOUBLE PRECISION PARMDL
15264       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15265 * jetset
15266
15267       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15268       PARAMETER (MAXLND=4000)
15269       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15270
15271       INTEGER PYK
15272
15273       DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
15274
15275       MODE = KMODE
15276       ISTSTG = 7
15277       IF (MODE.NE.1) ISTSTG = 8
15278       IREJ = 0
15279
15280       IP     = 0
15281       ISH    = 0
15282       INIEMC = 1
15283       NEND   = NHKK
15284       NACCEP = 0
15285       IFRG   = 0
15286       IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
15287       DO 10 I=NPOINT(3),NEND
15288 * sr 14.02.00: seems to be not necessary anymore, commented
15289 C        LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
15290 C    &            ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
15291          LACCEP = .TRUE.
15292 * pick up chains from dtevt1
15293          IDCHK = IDHKK(I)/10000
15294          IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
15295             IF (IDCHK.EQ.7) THEN
15296                IPJE = IDHKK(I)-IDCHK*10000
15297                IF (IPJE.NE.IFRG) THEN
15298                   IFRG = IPJE
15299                   IF (IFRG.GT.NFRG) GOTO 16
15300                ENDIF
15301             ELSE
15302                IPJE = 1
15303                IFRG = IFRG+1
15304                IF (IFRG.GT.NFRG) THEN
15305                   NFRG = -1
15306                   GOTO 16
15307                ENDIF
15308             ENDIF
15309 *   statistics counter
15310 c           IF (IDCH(I).LE.8)
15311 c    &         ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
15312 c           IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
15313 * special treatment for small chains already corrected to hadrons
15314             IF (IDRES(I).NE.0) THEN
15315                IF (IDRES(I).EQ.11) THEN
15316                   ID = IDXRES(I)
15317                ELSE
15318                   ID = IDT_IPDGHA(IDXRES(I))
15319                ENDIF
15320                IF (LEMCCK) THEN
15321                   CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15322      &                              PHKK(4,I),INIEMC,IDUM,IDUM)
15323                   INIEMC = 2
15324                ENDIF
15325                IP = IP+1
15326                IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
15327                P(IP,1) = PHKK(1,I)
15328                P(IP,2) = PHKK(2,I)
15329                P(IP,3) = PHKK(3,I)
15330                P(IP,4) = PHKK(4,I)
15331                P(IP,5) = PHKK(5,I)
15332                K(IP,1) = 1
15333                K(IP,2) = ID
15334                K(IP,3) = 0
15335                K(IP,4) = 0
15336                K(IP,5) = 0
15337                IHIST(2,I) = 10000*IPJE+IP
15338                IF (IHIST(1,I).LE.-100) THEN
15339                   ISH = ISH+1
15340                   IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15341                   ISJOIN(ISH) = I
15342                ENDIF
15343                N = IP
15344                IHISMO(IP) = I
15345             ELSE
15346                IJ  = 0
15347                DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
15348                   IF (LEMCCK) THEN
15349                      CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
15350      &                                   PHKK(4,KK),INIEMC,IDUM,IDUM)
15351                      CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
15352                      INIEMC = 2
15353                   ENDIF
15354                   ID = IDHKK(KK)
15355                   IF (ID.EQ.0) ID = 21
15356 c                  PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
15357 c                  AM0  = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
15358
15359 c                  AMRQ   = PYMASS(ID)
15360
15361 c                  AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
15362 c                  IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
15363 c     &                (ABS(IDIFF).EQ.0)) THEN
15364 cC                    WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
15365 c                     DELTA      = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
15366 c                     PHKK(4,KK) = PHKK(4,KK)+DELTA
15367 c                     PTOT1      = PTOT-DELTA
15368 c                     PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
15369 c                     PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
15370 c                     PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
15371 c                     PHKK(5,KK) = AMRQ
15372 c                  ENDIF
15373                   IP = IP+1
15374                   IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
15375                   P(IP,1) = PHKK(1,KK)
15376                   P(IP,2) = PHKK(2,KK)
15377                   P(IP,3) = PHKK(3,KK)
15378                   P(IP,4) = PHKK(4,KK)
15379                   P(IP,5) = PHKK(5,KK)
15380                   K(IP,1) = 1
15381                   K(IP,2) = ID
15382                   K(IP,3) = 0
15383                   K(IP,4) = 0
15384                   K(IP,5) = 0
15385                   IHIST(2,KK) = 10000*IPJE+IP
15386                   IF (IHIST(1,KK).LE.-100) THEN
15387                      ISH = ISH+1
15388                      IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15389                      ISJOIN(ISH) = KK
15390                   ENDIF
15391                   IJ = IJ+1
15392                   IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
15393                   IJOIN(IJ)  = IP
15394                   IHISMO(IP) = I
15395    11          CONTINUE
15396                N = IP
15397 * join the two-parton system
15398
15399                CALL PYJOIN(IJ,IJOIN)
15400
15401             ENDIF
15402             IDHKK(I) = 99999
15403          ENDIF
15404    10 CONTINUE
15405    16 CONTINUE
15406       N = IP
15407
15408       IF (IP.GT.0) THEN
15409
15410 * final state parton shower
15411          DO 136 NPJE=1,IPJE
15412             IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
15413                IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
15414                   DO 130 K1=1,ISH
15415                      IF (ISJOIN(K1).EQ.0) GOTO 130
15416                      I = ISJOIN(K1)
15417                      IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
15418      &                                                       GOTO 130
15419                      IH1 = IHIST(2,I)/10000
15420                      IF (IH1.NE.NPJE) GOTO 130
15421                      IH1 = IHIST(2,I)-IH1*10000
15422                      DO 135 K2=K1+1,ISH
15423                         IF (ISJOIN(K2).EQ.0) GOTO 135
15424                         II = ISJOIN(K2)
15425                         IH2 = IHIST(2,II)/10000
15426                         IF (IH2.NE.NPJE) GOTO 135
15427                         IH2 = IHIST(2,II)-IH2*10000
15428                         IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
15429                            PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
15430                            PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
15431
15432                            RQLUN = MIN(PT1,PT2)
15433                            CALL PYSHOW(IH1,IH2,RQLUN)
15434
15435                            ISJOIN(K1) = 0
15436                            ISJOIN(K2) = 0
15437                            GOTO 130
15438                         ENDIF
15439  135                 CONTINUE
15440  130              CONTINUE
15441                ENDIF
15442             ENDIF
15443  136     CONTINUE
15444
15445          CALL DT_INITJS(MODE)
15446 * hadronization
15447
15448          CALL PYEXEC
15449
15450          IF (MSTU(24).NE.0) THEN
15451             WRITE(LOUT,*) ' JETSET-reject at event',
15452      &                    NEVHKK,MSTU(24),KMODE
15453 C           CALL DT_EVTOUT(4)
15454
15455 C           CALL PYLIST(2)
15456
15457             GOTO 9999
15458          ENDIF
15459
15460 *   number of entries in LUJETS
15461
15462          NLINES = PYK(0,1)
15463
15464          NPYMEM = NLINES
15465
15466          DO 12 I=1,NLINES
15467             IFLG(I) = 0
15468    12    CONTINUE
15469
15470          DO 13 II=1,NLINES
15471
15472             IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
15473
15474 *  pick up mother resonance if possible and put it together with
15475 *  their decay-products into the common
15476                IDXMOR = K(II,3)
15477                IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
15478                   KFMOR = K(IDXMOR,2)
15479                   ISMOR = K(IDXMOR,1)
15480                ELSE
15481                   KFMOR = 91
15482                   ISMOR = 1
15483                ENDIF
15484                IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
15485      &             (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
15486                   ID = K(IDXMOR,2)
15487                   MO = IHISMO(PYK(IDXMOR,15))
15488                   PX = PYP(IDXMOR,1)
15489                   PY = PYP(IDXMOR,2)
15490                   PZ = PYP(IDXMOR,3)
15491                   PE = PYP(IDXMOR,4)
15492
15493                   CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15494                   IFLG(IDXMOR) = 1
15495                   MO = NHKK
15496                   DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
15497                      IF (PYK(JDAUG,7).EQ.1) THEN
15498                         ID = PYK(JDAUG,8)
15499                         PX = PYP(JDAUG,1)
15500                         PY = PYP(JDAUG,2)
15501                         PZ = PYP(JDAUG,3)
15502                         PE = PYP(JDAUG,4)
15503
15504                         CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15505                         IF (LEMCCK) THEN
15506                            PX = -PYP(JDAUG,1)
15507                            PY = -PYP(JDAUG,2)
15508                            PZ = -PYP(JDAUG,3)
15509                            PE = -PYP(JDAUG,4)
15510
15511                            CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15512                         ENDIF
15513                         IFLG(JDAUG) = 1
15514                      ENDIF
15515    15             CONTINUE
15516                ELSE
15517 *  there was no mother resonance
15518                   MO = IHISMO(PYK(II,15))
15519                   ID = PYK(II,8)
15520                   PX = PYP(II,1)
15521                   PY = PYP(II,2)
15522                   PZ = PYP(II,3)
15523                   PE = PYP(II,4)
15524
15525                   CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15526                   IF (LEMCCK) THEN
15527                      PX = -PYP(II,1)
15528                      PY = -PYP(II,2)
15529                      PZ = -PYP(II,3)
15530                      PE = -PYP(II,4)
15531
15532                      CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15533                   ENDIF
15534                ENDIF
15535             ENDIF
15536    13    CONTINUE
15537          IF (LEMCCK) THEN
15538             CHKLEV = TINY1
15539             CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
15540 C           IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
15541          ENDIF
15542
15543 * global energy-momentum & flavor conservation check
15544 **sr 16.5. this check is skipped in case of phojet-treatment
15545          IF (MCGENE.EQ.1)
15546      &      CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
15547
15548 * update statistics-counter for diffraction
15549 c        IF (IFLAGD.NE.0) THEN
15550 c           ICDIFF(1) = ICDIFF(1)+1
15551 c           IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
15552 c           IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
15553 c           IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
15554 c           IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
15555 c        ENDIF
15556
15557       ENDIF
15558
15559       RETURN
15560
15561  9999 CONTINUE
15562       IREJ = 1
15563       RETURN
15564       END
15565
15566 *$ CREATE DT_DECAYS.FOR
15567 *COPY DT_DECAYS
15568 *
15569 *===decay==============================================================*
15570 *
15571       SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15572
15573 ************************************************************************
15574 * Resonance-decay.                                                     *
15575 * This subroutine replaces DDECAY/DECHKK.                              *
15576 *             PIN(4)      4-momentum of resonance          (input)     *
15577 *             IDXIN       BAMJET-index of resonance        (input)     *
15578 *             POUT(20,4)  4-momenta of decay-products      (output)    *
15579 *             IDXOUT(20)  BAMJET-indices of decay-products (output)    *
15580 *             NSEC        number of secondaries            (output)    *
15581 * Adopted from the original version DECHKK.                            *
15582 * This version dated 09.01.95 is written by S. Roesler                 *
15583 ************************************************************************
15584
15585       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15586       SAVE
15587
15588       PARAMETER ( LINP = 10 ,
15589      &            LOUT = 6 ,
15590      &            LDAT = 9 )
15591
15592       PARAMETER (TINY17=1.0D-17)
15593
15594 * HADRIN: decay channel information
15595       PARAMETER (IDMAX9=602)
15596       CHARACTER*8 ZKNAME
15597       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15598
15599 * particle properties (BAMJET index convention)
15600       CHARACTER*8  ANAME
15601       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15602      &                IICH(210),IIBAR(210),K1(210),K2(210)
15603
15604 * flags for input different options
15605       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15606       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15607      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15608
15609       DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
15610      &          EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
15611      &          CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
15612
15613 * ISTAB = 1 strong and weak decays
15614 *       = 2 strong decays only
15615 *       = 3 strong decays, weak decays for charmed particles and tau
15616 *           leptons only
15617       DATA ISTAB /2/
15618
15619       IREJ = 0
15620       NSEC = 0
15621 * put initial resonance to stack
15622       NSTK = 1
15623       IDXSTK(NSTK) = IDXIN
15624       DO 5 I=1,4
15625          PI(NSTK,I) = PIN(I)
15626     5 CONTINUE
15627
15628 * store initial configuration for energy-momentum cons. check
15629       IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
15630      &                                   PI(NSTK,4),1,IDUM,IDUM)
15631
15632   100 CONTINUE
15633 * get particle from stack
15634       IDXI = IDXSTK(NSTK)
15635 * skip stable particles
15636       IF (ISTAB.EQ.1) THEN
15637          IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
15638          IF ((IDXI.GE.  1).AND.(IDXI.LE.  7)) GOTO 10
15639       ELSEIF (ISTAB.EQ.2) THEN
15640          IF ((IDXI.GE.  1).AND.(IDXI.LE. 30)) GOTO 10
15641          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15642          IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
15643          IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
15644          IF ( IDXI.EQ.109)                    GOTO 10
15645          IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
15646       ELSEIF (ISTAB.EQ.3) THEN
15647          IF ((IDXI.GE.  1).AND.(IDXI.LE. 23)) GOTO 10
15648          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15649          IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
15650          IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
15651       ENDIF
15652
15653 * calculate direction cosines and Lorentz-parameter of decaying part.
15654       PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
15655       PTOT = MAX(PTOT,TINY17)
15656       DO 1 I=1,3
15657          DCOS(I) = PI(NSTK,I)/PTOT
15658     1 CONTINUE
15659       GAM  = PI(NSTK,4)/AAM(IDXI)
15660       BGAM = PTOT/AAM(IDXI)
15661
15662 * get decay-channel
15663       KCHAN = K1(IDXI)-1
15664     2 CONTINUE
15665       KCHAN = KCHAN+1
15666       IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
15667
15668 * identities of secondaries
15669       IDX(1) = NZK(KCHAN,1)
15670       IDX(2) = NZK(KCHAN,2)
15671       IF (IDX(2).LT.1) GOTO 9999
15672       IDX(3) = NZK(KCHAN,3)
15673
15674 * handle decay in rest system of decaying particle
15675       IF (IDX(3).EQ.0) THEN
15676 *   two-particle decay
15677          NDEC = 2
15678          CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
15679      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15680      &               AAM(IDX(1)),AAM(IDX(2)))
15681       ELSE
15682 *   three-particle decay
15683          NDEC = 3
15684          CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
15685      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15686      &               CODF(3),COFF(3),SIFF(3),
15687      &               AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15688       ENDIF
15689       NSTK = NSTK-1
15690
15691 * transform decay products back
15692       DO 3 I=1,NDEC
15693          NSTK = NSTK+1
15694          CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15695      &               CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15696      &               PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15697 * add particle to stack
15698          IDXSTK(NSTK) = IDX(I)
15699          DO 4 J=1,3
15700             PI(NSTK,J) = DCOSF(J)*PFF(I)
15701     4    CONTINUE
15702     3 CONTINUE
15703       GOTO 100
15704
15705    10 CONTINUE
15706 * stable particle, put to output-arrays
15707       NSEC = NSEC+1
15708       DO 6 I=1,4
15709          POUT(NSEC,I) = PI(NSTK,I)
15710     6 CONTINUE
15711       IDXOUT(NSEC) = IDXSTK(NSTK)
15712 * store secondaries for energy-momentum conservation check
15713       IF (LEMCCK)
15714      &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15715      &            -POUT(NSEC,4),2,IDUM,IDUM)
15716       NSTK = NSTK-1
15717       IF (NSTK.GT.0) GOTO 100
15718
15719 * check energy-momentum conservation
15720       IF (LEMCCK) THEN
15721          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15722          IF (IREJ1.NE.0) GOTO 9999
15723       ENDIF
15724
15725       RETURN
15726
15727  9999 CONTINUE
15728       IREJ = 1
15729       RETURN
15730       END
15731
15732 *$ CREATE DT_DECAY1.FOR
15733 *COPY DT_DECAY1
15734 *
15735 *===decay1=============================================================*
15736 *
15737       SUBROUTINE DT_DECAY1
15738
15739 ************************************************************************
15740 * Decay of resonances stored in DTEVT1.                                *
15741 * This version dated 20.01.95 is written by S. Roesler                 *
15742 ************************************************************************
15743
15744       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15745       SAVE
15746
15747       PARAMETER ( LINP = 10 ,
15748      &            LOUT = 6 ,
15749      &            LDAT = 9 )
15750
15751 * event history
15752
15753       PARAMETER (NMXHKK=200000)
15754
15755       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15756      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15757      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15758
15759 * extended event history
15760       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15761      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15762      &                IHIST(2,NMXHKK)
15763
15764       DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15765
15766       NEND = NHKK
15767 C     DO 1 I=NPOINT(5),NEND
15768       DO 1 I=NPOINT(4),NEND
15769          IF (ABS(ISTHKK(I)).EQ.1) THEN
15770             DO 2 K=1,4
15771                PIN(K) = PHKK(K,I)
15772     2       CONTINUE
15773             IDXIN = IDBAM(I)
15774             CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15775             IF (NSEC.GT.1) THEN
15776                DO 3 N=1,NSEC
15777                   IDHAD = IDT_IPDGHA(IDXOUT(N))
15778                   CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15779      &                               POUT(N,3),POUT(N,4),0,0,0)
15780     3          CONTINUE
15781             ENDIF
15782          ENDIF
15783     1 CONTINUE
15784
15785       RETURN
15786       END
15787
15788 *$ CREATE DT_DECPI0.FOR
15789 *COPY DT_DECPI0
15790 *
15791 *===decpi0=============================================================*
15792 *
15793       SUBROUTINE DT_DECPI0
15794
15795 ************************************************************************
15796 * Decay of pi0 handled with JETSET.                                    *
15797 * This version dated 18.02.96 is written by S. Roesler                 *
15798 ************************************************************************
15799
15800       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15801       SAVE
15802
15803       PARAMETER ( LINP = 10 ,
15804      &            LOUT = 6 ,
15805      &            LDAT = 9 )
15806
15807       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15808
15809 * event history
15810
15811       PARAMETER (NMXHKK=200000)
15812
15813       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15814      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15815      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15816
15817 * extended event history
15818       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15819      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15820      &                IHIST(2,NMXHKK)
15821
15822       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15823       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15824       PARAMETER (MAXLND=4000)
15825       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15826
15827 * flags for input different options
15828       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15829       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15830      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15831
15832       INTEGER PYCOMP,PYK
15833
15834       DIMENSION IHISMO(NMXHKK),P1(4)
15835
15836       TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15837
15838       CALL DT_INITJS(2)
15839 * allow pi0 decay
15840
15841       KC = PYCOMP(111)
15842
15843       MDCY(KC,1) = 1
15844
15845       NN  = 0
15846       INI = 0
15847       DO 1 I=1,NHKK
15848          IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15849             IF (INI.EQ.0) THEN
15850                INI = 1
15851             ELSE
15852                INI = 2
15853             ENDIF
15854             IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15855      &                                    PHKK(4,I),INI,IDUM,IDUM)
15856             PT    = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15857             PTOT  = SQRT(PT**2+PHKK(3,I)**2)
15858             COSTH = PHKK(3,I)/(PTOT+TINY10)
15859             IF (COSTH.GT.ONE) THEN
15860                THETA = ZERO
15861             ELSEIF (COSTH.LT.-ONE) THEN
15862                THETA = TWOPI/2.0D0
15863             ELSE
15864                THETA = ACOS(COSTH)
15865             ENDIF
15866             PHI     = ASIN(PHKK(2,I)/(PT  +TINY10))
15867             IF (PHKK(1,I).LT.0.0D0)
15868
15869      &         PHI  = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15870
15871             ENER    = PHKK(4,I)
15872             NN      = NN+1
15873             KTEMP   = MSTU(10)
15874             MSTU(10)= 1
15875             P(NN,5) = PHKK(5,I)
15876
15877             CALL PY1ENT(NN,111,ENER,THETA,PHI)
15878
15879             MSTU(10)  = KTEMP
15880             IHISMO(NN)= I
15881          ENDIF
15882     1 CONTINUE
15883       IF (NN.GT.0) THEN
15884
15885          CALL PYEXEC
15886
15887          NLINES = PYK(0,1)
15888
15889          DO 2 II=1,NLINES
15890
15891             IF (PYK(II,7).EQ.1) THEN
15892
15893                DO 3 KK=1,4
15894
15895                   P1(KK) = PYP(II,KK)
15896
15897     3          CONTINUE
15898
15899                ID = PYK(II,8)
15900                MO = IHISMO(PYK(II,15))
15901
15902                CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15903                IF (LEMCCK)
15904      &            CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15905      &                                            IDUM,IDUM)
15906 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15907                ISTHKK(MO) = -2
15908             ENDIF
15909     2    CONTINUE
15910          IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15911       ENDIF
15912       MDCY(KC,1) = 0
15913
15914       RETURN
15915       END
15916
15917 *$ CREATE DT_DTWOPD.FOR
15918 *COPY DT_DTWOPD
15919 *
15920 *===dtwopd=============================================================*
15921 *
15922       SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15923      &                                            COF2,SIF2,AM1,AM2)
15924
15925 ************************************************************************
15926 * Two-particle decay.                                                  *
15927 *  UMO                 cm-energy of the decaying system       (input)  *
15928 *  AM1/AM2             masses of the decay products           (input)  *
15929 *  ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15930 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15931 * Revised by S. Roesler, 20.11.95                                      *
15932 ************************************************************************
15933
15934       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15935       SAVE
15936
15937       PARAMETER ( LINP = 10 ,
15938      &            LOUT = 6 ,
15939      &            LDAT = 9 )
15940
15941       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15942
15943       IF (UMO.LT.(AM1+AM2)) THEN
15944          WRITE(LOUT,1000) UMO,AM1,AM2
15945  1000    FORMAT(1X,'DTWOPD:    inconsistent kinematics - UMO,AM1,AM2 ',
15946      &          3E12.3)
15947          STOP
15948       ENDIF
15949
15950       ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15951       ECM2 = UMO-ECM1
15952       PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15953       PCM2 = PCM1
15954       CALL DT_DSFECF(SIF1,COF1)
15955       COD1 = TWO*DT_RNDM(PCM2)-ONE
15956       COD2 = -COD1
15957       COF2 = -COF1
15958       SIF2 = -SIF1
15959
15960       RETURN
15961       END
15962
15963 *$ CREATE DT_DTHREP.FOR
15964 *COPY DT_DTHREP
15965 *
15966 *===dthrep=============================================================*
15967 *
15968       SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15969      &                  SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15970
15971 ************************************************************************
15972 * Three-particle decay.                                                *
15973 *  UMO                 cm-energy of the decaying system       (input)  *
15974 *  AM1/2/3             masses of the decay products           (input)  *
15975 *  ECM1/2/2,PCM1/2/3   cm-energies/momenta of the decay prod. (output) *
15976 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15977 *                                                                      *
15978 * Threpd89: slight revision by A. Ferrari                              *
15979 * Last change on   11-oct-93   by    Alfredo Ferrari, INFN - Milan     *
15980 * Revised by S. Roesler, 20.11.95                                      *
15981 ************************************************************************
15982
15983       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15984       SAVE
15985
15986       PARAMETER ( LINP = 10 ,
15987      &            LOUT = 6 ,
15988      &            LDAT = 9 )
15989
15990       PARAMETER ( ANGLSQ = 2.5D-31 )
15991       PARAMETER ( AZRZRZ = 1.0D-30 )
15992       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
15993       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
15994       PARAMETER ( ONEONE = 1.D+00 )
15995       PARAMETER ( TWOTWO = 2.D+00 )
15996       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15997
15998       COMMON /HNGAMR/ REDU,AMO,AMM(15)
15999
16000 * flags for input different options
16001       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16002       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16003      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16004
16005       DIMENSION F(5),XX(5)
16006       DATA EPS /AZRZRZ/
16007
16008       UMOO=UMO+UMO
16009 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
16010 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
16011 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
16012       UUMO=UMO
16013       AAM1=AM1
16014       AAM2=AM2
16015       AAM3=AM3
16016       GU=(AM2+AM3)**2
16017       GO=(UMO-AM1)**2
16018 *     UFAK=1.0000000000001D0
16019 *     IF (GU.GT.GO) UFAK=0.9999999999999D0
16020       IF (GU.GT.GO) THEN
16021          UFAK=ONEMNS
16022       ELSE
16023          UFAK=ONEPLS
16024       END IF
16025       OFAK=2.D0-UFAK
16026       GU=GU*UFAK
16027       GO=GO*OFAK
16028       DS2=(GO-GU)/99.D0
16029       AM11=AM1*AM1
16030       AM22=AM2*AM2
16031       AM33=AM3*AM3
16032       UMO2=UMO*UMO
16033       RHO2=0.D0
16034       S22=GU
16035       DO 124 I=1,100
16036          S21=S22
16037          S22=GU+(I-1.D0)*DS2
16038          RHO1=RHO2
16039          RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
16040      *                                             (S22+EPS)
16041          IF(RHO2.LT.RHO1) GO TO 125
16042   124 CONTINUE
16043   125 S2SUP=(S22-S21)*.5D0+S21
16044       SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
16045      *                                           (S2SUP+EPS)
16046       SUPRHO=SUPRHO*1.05D0
16047       XO=S21-DS2
16048       IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
16049       IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
16050       XX(1)=XO
16051       XX(3)=S22
16052       X1=(XO+S22)*0.5D0
16053       XX(2)=X1
16054       F(3)=RHO2
16055       F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
16056       F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
16057       DO 126 I=1,16
16058          X4=(XX(1)+XX(2))*0.5D0
16059          X5=(XX(2)+XX(3))*0.5D0
16060          F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
16061      *                                               (X4+EPS)
16062          F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
16063      *                                               (X5+EPS)
16064          XX(4)=X4
16065          XX(5)=X5
16066          DO 128 II=1,5
16067             IA=II
16068             DO 128 III=IA,5
16069                IF (F (II).GE.F (III)) GO TO 128
16070                FH=F(II)
16071                F(II)=F(III)
16072                F(III)=FH
16073                FH=XX(II)
16074                XX(II)=XX(III)
16075                XX(III)=FH
16076 128      CONTINUE
16077          SUPRHO=F(1)
16078          S2SUP=XX(1)
16079          DO 129 II=1,3
16080             IA=II
16081             DO 129 III=IA,3
16082                IF (XX(II).GE.XX(III)) GO TO 129
16083                FH=F(II)
16084                F(II)=F(III)
16085                F(III)=FH
16086                FH=XX(II)
16087                XX(II)=XX(III)
16088                XX(III)=FH
16089 129      CONTINUE
16090 126   CONTINUE
16091       AM23=(AM2+AM3)**2
16092       ITH=0
16093       REDU=2.D0
16094     1 CONTINUE
16095       ITH=ITH+1
16096       IF (ITH.GT.200) REDU=-9.D0
16097       IF (ITH.GT.200) GO TO 400
16098       C=DT_RNDM(REDU)
16099 *     S2=AM23+C*((UMO-AM1)**2-AM23)
16100       S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
16101       Y=DT_RNDM(S2)
16102       Y=Y*SUPRHO
16103       RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
16104       IF(Y.GT.RHO) GO TO 1
16105 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
16106       S1=DT_RNDM(S2)
16107       S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
16108      &RHO*.5D0
16109       S3=UMO2+AM11+AM22+AM33-S1-S2
16110       ECM1=(UMO2+AM11-S2)/UMOO
16111       ECM2=(UMO2+AM22-S3)/UMOO
16112       ECM3=(UMO2+AM33-S1)/UMOO
16113       PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
16114       PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
16115       PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
16116       CALL DT_DSFECF(SFE,CFE)
16117 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
16118 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
16119       PCM12 = PCM1 * PCM2
16120       IF ( PCM12 .LT. ANGLSQ ) GO TO 200
16121       COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
16122       GO TO 300
16123  200  CONTINUE
16124          UW=DT_RNDM(S1)
16125          COSTH=(UW-0.5D+00)*2.D+00
16126  300  CONTINUE
16127 *     IF(ABS(COSTH).GT.0.9999999999999999D0)
16128 *    &COSTH=SIGN(0.9999999999999999D0,COSTH)
16129       IF(ABS(COSTH).GT.ONEONE)
16130      &COSTH=SIGN(ONEONE,COSTH)
16131       IF (REDU.LT.1.D+00) RETURN
16132       COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
16133 *     IF(ABS(COSTH2).GT.0.9999999999999999D0)
16134 *    &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
16135       IF(ABS(COSTH2).GT.ONEONE)
16136      &COSTH2=SIGN(ONEONE,COSTH2)
16137       SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
16138       SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
16139       SINTH1=COSTH2*SINTH-COSTH*SINTH2
16140       COSTH1=COSTH*COSTH2+SINTH2*SINTH
16141 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
16142 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
16143 C***THE DIRECTION OF PARTICLE 3
16144 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
16145       CX11=-COSTH1
16146       CY11=SINTH1*CFE
16147       CZ11=SINTH1*SFE
16148       CX22=-COSTH2
16149       CY22=-SINTH2*CFE
16150       CZ22=-SINTH2*SFE
16151       CALL DT_DSFECF(SIF3,COF3)
16152       COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
16153       SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
16154     2 FORMAT(5F20.15)
16155       COD1=CX11*COD3+CZ11*SID3
16156       CHLP=(ONEONE-COD1)*(ONEONE+COD1)
16157       IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
16158      &CX11,CZ11
16159       SID1=SQRT(CHLP)
16160       COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
16161       SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
16162       COD2=CX22*COD3+CZ22*SID3
16163       SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
16164       COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
16165       SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
16166  400  CONTINUE
16167 * === Energy conservation check: === *
16168       EOCHCK = UMO - ECM1 - ECM2 - ECM3
16169 *     SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
16170 *     SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
16171 *     SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
16172       PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
16173       PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
16174      &       + PCM3 * COF3 * SID3
16175       PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
16176      &       + PCM3 * SIF3 * SID3
16177       EOCMPR = 1.D-12 * UMO
16178       IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
16179      &     .GT. EOCMPR ) THEN
16180 **sr 5.5.95 output-unit changed
16181          IF (IOULEV(1).GT.0) THEN
16182             WRITE(LOUT,*)
16183      &      ' *** Threpd: energy/momentum conservation failure! ***',
16184      &      EOCHCK,PXCHCK,PYCHCK,PZCHCK
16185             WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
16186          ENDIF
16187 **
16188       END IF
16189       RETURN
16190       END
16191
16192 *$ CREATE DT_DBKLAS.FOR
16193 *COPY DT_DBKLAS
16194 *
16195 *===dbklas=============================================================*
16196 *
16197       SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
16198
16199       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16200       SAVE
16201
16202       PARAMETER ( LINP = 10 ,
16203      &            LOUT = 6 ,
16204      &            LDAT = 9 )
16205
16206 * quark-content to particle index conversion (DTUNUC 1.x)
16207       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16208      &                IA08(6,21),IA10(6,21)
16209
16210       IF (I) 20,20,10
16211 * baryons
16212    10 CONTINUE
16213       CALL DT_INDEXD(J,K,IND)
16214       I8  = IB08(I,IND)
16215       I10 = IB10(I,IND)
16216       IF (I8.LE.0) I8 = I10
16217       RETURN
16218 * antibaryons
16219    20 CONTINUE
16220       II = IABS(I)
16221       JJ = IABS(J)
16222       KK = IABS(K)
16223       CALL DT_INDEXD(JJ,KK,IND)
16224       I8  = IA08(II,IND)
16225       I10 = IA10(II,IND)
16226       IF (I8.LE.0) I8 = I10
16227
16228       RETURN
16229       END
16230
16231 *$ CREATE DT_INDEXD.FOR
16232 *COPY DT_INDEXD
16233 *
16234 *===indexd=============================================================*
16235 *
16236       SUBROUTINE DT_INDEXD(KA,KB,IND)
16237
16238       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16239       SAVE
16240
16241       PARAMETER ( LINP = 10 ,
16242      &            LOUT = 6 ,
16243      &            LDAT = 9 )
16244
16245       KP = KA*KB
16246       KS = KA+KB
16247       IF (KP.EQ.1) IND=1
16248       IF (KP.EQ.2) IND=2
16249       IF (KP.EQ.3) IND=3
16250       IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
16251       IF (KP.EQ.5) IND=5
16252       IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
16253       IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
16254       IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
16255       IF (KP.EQ.8)  IND=9
16256       IF (KP.EQ.10) IND=10
16257       IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
16258       IF (KP.EQ.9)  IND=12
16259       IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
16260       IF (KP.EQ.15) IND=14
16261       IF (KP.EQ.18) IND=15
16262       IF (KP.EQ.16) IND=16
16263       IF (KP.EQ.20) IND=17
16264       IF (KP.EQ.24) IND=18
16265       IF (KP.EQ.25) IND=19
16266       IF (KP.EQ.30) IND=20
16267       IF (KP.EQ.36) IND=21
16268
16269       RETURN
16270       END
16271
16272 *$ CREATE DT_DCHANT.FOR
16273 *COPY DT_DCHANT
16274 *
16275 *===dchant=============================================================*
16276 *
16277       SUBROUTINE DT_DCHANT
16278
16279       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16280       SAVE
16281
16282       PARAMETER ( LINP = 10 ,
16283      &            LOUT = 6 ,
16284      &            LDAT = 9 )
16285
16286       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16287
16288 * HADRIN: decay channel information
16289       PARAMETER (IDMAX9=602)
16290       CHARACTER*8 ZKNAME
16291       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
16292
16293 * particle properties (BAMJET index convention)
16294       CHARACTER*8  ANAME
16295       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16296      &                IICH(210),IIBAR(210),K1(210),K2(210)
16297
16298       DIMENSION HWT(IDMAX9)
16299
16300 * change of weights wt from absolut values into the sum of wt of a dec.
16301       DO 10 J=1,IDMAX9
16302          HWT(J) = ZERO
16303    10 CONTINUE
16304 C     DO 999 KKK=1,210
16305 C        WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
16306 C    &      ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
16307 C    &      K1(KKK),K2(KKK)
16308 C 999 CONTINUE
16309 C     STOP
16310       DO 30 I=1,210
16311          IK1 = K1(I)
16312          IK2 = K2(I)
16313          HV  = ZERO
16314          DO 20 J=IK1,IK2
16315             HV     = HV+WT(J)
16316             HWT(J) = HV
16317 **sr 13.1.95
16318             IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
16319  1000       FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
16320    20    CONTINUE
16321    30 CONTINUE
16322       DO 40 J=1,IDMAX9
16323          WT(J) = HWT(J)
16324    40 CONTINUE
16325
16326       RETURN
16327       END
16328
16329 *$ CREATE DT_DDATAR.FOR
16330 *COPY DT_DDATAR
16331 *
16332 *===ddatar=============================================================*
16333 *
16334       SUBROUTINE DT_DDATAR
16335
16336       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16337       SAVE
16338
16339       PARAMETER ( LINP = 10 ,
16340      &            LOUT = 6 ,
16341      &            LDAT = 9 )
16342
16343       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16344
16345 * quark-content to particle index conversion (DTUNUC 1.x)
16346       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16347      &                IA08(6,21),IA10(6,21)
16348
16349       DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
16350
16351       DATA IV/ 33, 34, 38,123,  0,  0, 32, 33, 39,124,
16352      &          0,  0, 36, 37, 96,127,  0,  0,126,125,
16353      &        128,129,14*0/
16354       DATA IP/ 23, 14, 16,116,  0,  0, 13, 23, 25,117,
16355      &          0,  0, 15, 24, 31,120,  0,  0,119,118,
16356      &        121,122,14*0/
16357       DATA IB/  0,  1, 21,140,  0,  0,  8, 22,137,  0,
16358      &          0, 97,138,  0,  0,146,  0,  0,  0,  0,
16359      &          0,  1,  8, 22,137,  0,  0,  0, 20,142,
16360      &          0,  0, 98,139,  0,  0,147,  0,  0,  0,
16361      &          0,  0, 21, 22, 97,138,  0,  0, 20, 98,
16362      &        139,  0,  0,  0,145,  0,  0,148,  0,  0,
16363      &          0,  0,  0,140,137,138,146,  0,  0,142,
16364      &        139,147,  0,  0,145,148,           50*0/
16365       DATA IBB/53, 54,104,161,  0,  0, 55,105,162,  0,
16366      &          0,107,164,  0,  0,167,  0,  0,  0,  0,
16367      &          0, 54, 55,105,162,  0,  0, 56,106,163,
16368      &          0,  0,108,165,  0,  0,168,  0,  0,  0,
16369      &          0,  0,104,105,107,164,  0,  0,106,108,
16370      &        165,  0,  0,109,166,  0,  0,169,  0,  0,
16371      &          0,  0,  0,161,162,164,167,  0,  0,163,
16372      &        165,168,  0,  0,166,169,  0,  0,170,47*0/
16373       DATA IA/  0,  2, 99,152,  0,  0,  9,100,149,  0,
16374      &          0,102,150,  0,  0,158,  0,  0,  0,  0,
16375      &          0,  2,  9,100,149,  0,  0,  0,101,154,
16376      &          0,  0,103,151,  0,  0,159,  0,  0,  0,
16377      &          0,  0, 99,100,102,150,  0,  0,101,103,
16378      &        151,  0,  0,  0,157,  0,  0,160,  0,  0,
16379      &          0,  0,  0,152,149,150,158,  0,  0,154,
16380      &        151,159,  0,  0,157,160,           50*0/
16381       DATA IAA/67, 68,110,171,  0,  0, 69,111,172,  0,
16382      &          0,113,174,  0,  0,177,  0,  0,  0,  0,
16383      &          0, 68, 69,111,172,  0,  0, 70,112,173,
16384      &          0,  0,114,175,  0,  0,178,  0,  0,  0,
16385      &          0,  0,110,111,113,174,  0,  0,112,114,
16386      &        175,  0,  0,115,176,  0,  0,179,  0,  0,
16387      &          0,  0,  0,171,172,174,177,  0,  0,173,
16388      &        175,178,  0,  0,176,179,  0,  0,180,47*0/
16389
16390       L=0
16391       DO 2 I=1,6
16392          DO 1 J=1,6
16393             L = L+1
16394             IMPS(I,J) = IP(L)
16395             IMVE(I,J) = IV(L)
16396     1    CONTINUE
16397     2 CONTINUE
16398       L=0
16399       DO 4 I=1,6
16400          DO 3 J=1,21
16401             L = L+1
16402             IB08(I,J) = IB(L)
16403             IB10(I,J) = IBB(L)
16404             IA08(I,J) = IA(L)
16405             IA10(I,J) = IAA(L)
16406     3    CONTINUE
16407     4 CONTINUE
16408 C     A1  = 0.88D0
16409 C     B1  = 3.0D0
16410 C     B2  = 3.0D0
16411 C     B3  = 8.0D0
16412 C     LT  = 0
16413 C     LB  = 0
16414 C     BET = 12.0D0
16415 C     AS  = 0.25D0
16416 C     B8  = 0.33D0
16417 C     AME = 0.95D0
16418 C     DIQ = 0.375D0
16419 C     ISU = 4
16420
16421       RETURN
16422       END
16423
16424 *$ CREATE DT_INITJS.FOR
16425 *COPY DT_INITJS
16426 *
16427 *===initjs=============================================================*
16428 *
16429       SUBROUTINE DT_INITJS(MODE)
16430
16431 ************************************************************************
16432 * Initialize JETSET paramters.                                         *
16433 *           MODE = 0 default settings                                  *
16434 *                = 1 PHOJET settings                                   *
16435 *                = 2 DTUNUC settings                                   *
16436 * This version dated 16.02.96 is written by S. Roesler                 *
16437 *                                                                      *
16438 * Last change 27.12.2006 by S. Roesler.                                *
16439 ************************************************************************
16440
16441       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16442       SAVE
16443
16444       PARAMETER ( LINP = 10 ,
16445      &            LOUT = 6 ,
16446      &            LDAT = 9 )
16447
16448       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16449
16450       LOGICAL LFIRST,LFIRDT,LFIRPH
16451
16452 *      INCLUDE '(DIMPAR)'
16453 *     DIMPAR taken from FLUKA
16454       PARAMETER ( MXXRGN =20000 )
16455       PARAMETER ( MXXMDF =  710 )
16456       PARAMETER ( MXXMDE =  702 )
16457       PARAMETER ( MFSTCK =40000 )
16458       PARAMETER ( MESTCK =  100 )
16459       PARAMETER ( MOSTCK = 2000 )
16460       PARAMETER ( MXPRSN =  100 )
16461       PARAMETER ( MXPDPM =  800 )
16462       PARAMETER ( MXPSCS =30000 )
16463       PARAMETER ( MXGLWN =  300 )
16464       PARAMETER ( MXOUTU =   50 )
16465       PARAMETER ( NALLWP =   64 )
16466       PARAMETER ( NELEMX =   80 )
16467       PARAMETER ( MPDPDX =   18 )
16468       PARAMETER ( MXHTTR =  260 )
16469       PARAMETER ( MXSEAX =   20 )
16470       PARAMETER ( MXHTNC = MXSEAX + 1 )
16471       PARAMETER ( ICOMAX = 2400 )
16472       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
16473       PARAMETER ( NSTBIS =  304 )
16474       PARAMETER ( NQSTIS =   46 )
16475       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
16476       PARAMETER ( MXPABL =  120 )
16477       PARAMETER ( IDMAXP =  450 )
16478       PARAMETER ( IDMXDC = 2000 )
16479       PARAMETER ( MXMCIN =  410 )
16480       PARAMETER ( IHYPMX =    4 )
16481       PARAMETER ( MKBMX1 =   11 )
16482       PARAMETER ( MKBMX2 =   11 )
16483       PARAMETER ( MXIRRD = 2500 )
16484       PARAMETER ( MXTRDC = 1500 )
16485       PARAMETER ( NKTL   =   17 )
16486       PARAMETER ( NBLNMX = 40000000 )
16487
16488 *      INCLUDE '(PART)'
16489 *     PART taken from FLUKA
16490       PARAMETER ( KPETA0 =  31 )
16491       PARAMETER ( KPRHOP =  32 )
16492       PARAMETER ( KPRHO0 =  33 )
16493       PARAMETER ( KPRHOM =  34 )
16494       PARAMETER ( KPOME0 =  35 )
16495       PARAMETER ( KPPHI0 =  96 )
16496       PARAMETER ( KPDEPP =  53 )
16497       PARAMETER ( KPDELP =  54 )
16498       PARAMETER ( KPDEL0 =  55 )
16499       PARAMETER ( KPDELM =  56 )
16500       PARAMETER ( KPN14P =  91 )
16501       PARAMETER ( KPN140 =  92 )
16502 *  Low mass diffraction partners:
16503       PARAMETER ( KDETA0 =   0 )
16504       PARAMETER ( KDRHOP =   0 )
16505       PARAMETER ( KDRHO0 = 210 )
16506       PARAMETER ( KDRHOM =   0 )
16507       PARAMETER ( KDOME0 = 210 )
16508       PARAMETER ( KDPHI0 = 210 )
16509       PARAMETER ( KDDEPP =   0 )
16510       PARAMETER ( KDDELP =   0 )
16511       PARAMETER ( KDDEL0 =   0 )
16512       PARAMETER ( KDDELM =   0 )
16513       PARAMETER ( KDN14P =   0 )
16514       PARAMETER ( KDN140 =   0 )
16515 *
16516       CHARACTER*8  ANAME
16517       COMMON / PART /  AM     (-6:IDMAXP), GA     (-6:IDMAXP),
16518      &                 TAU    (-6:IDMAXP), AMDISC (-6:IDMAXP),
16519      &                 ZMNABS (-6:IDMAXP), ATNMNA (-6:IDMAXP),
16520      &                 ATXN14,     ATMN14, RNRN14    (-10:10),
16521      &                 ICH    (-6:IDMAXP), IBAR   (-6:IDMAXP),
16522      &                 ISOSYM (-6:IDMAXP), ICHCON (-6:IDMAXP),
16523      &                 K1     (-6:IDMAXP), K2     (-6:IDMAXP),
16524      &                 KPTOIP (-6:IDMAXP), IPTOKP (-6:NALLWP),
16525      &                 KPTOIA (-6:IDMAXP), IATOKP (-6:MXPABL),
16526      &                 IDCFLG (-6:NALLWP), IPTYPE (-6:NALLWP)
16527
16528       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16529       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16530       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16531
16532 * flags for particle decays
16533       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
16534      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
16535      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
16536
16537 * flags for input different options
16538       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16539       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16540      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16541
16542       INTEGER PYCOMP
16543
16544       DIMENSION IDXSTA(40)
16545       DATA IDXSTA
16546 *          K0s   pi0  lam   alam  sig+  asig+ sig-  asig- tet0  atet0
16547      &  /  310,  111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
16548 *          tet- atet-  om-  aom-   D+    D-    D0    aD0   Ds+   aDs+
16549      &    3312,-3312, 3334,-3334,  411, -411,  421, -421,  431, -431,
16550 *          etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
16551      &     441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
16552 *         Ksic0 aKsic+aKsic0 sig0 asig0
16553      &    4132,-4232,-4132, 3212,-3212, 5*0/
16554
16555       DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
16556
16557       IF (LFIRST) THEN
16558 * save default settings
16559          PDEF1  = PARJ(1)
16560          PDEF2  = PARJ(2)
16561          PDEF3  = PARJ(3)
16562          PDEF5  = PARJ(5)
16563          PDEF6  = PARJ(6)
16564          PDEF7  = PARJ(7)
16565          PDEF18 = PARJ(18)
16566          PDEF19 = PARJ(19)
16567          PDEF21 = PARJ(21)
16568          PDEF42 = PARJ(42)
16569          MDEF12 = MSTJ(12)
16570 * LUJETS / PYJETS array-dimensions
16571
16572          MSTU(4) = 4000
16573
16574 * increase maximum number of JETSET-error prints
16575          MSTU(22) = 50000
16576 * prevent particles decaying
16577          DO 1 I=1,35
16578             IF (I.LT.34) THEN
16579
16580                KC = PYCOMP(IDXSTA(I))
16581
16582                IF (KC.GT.0) THEN
16583                   IF (I.EQ.2) THEN
16584 *  pi0 decay
16585 C                    MDCY(KC,1) = 1
16586                      MDCY(KC,1) = 0
16587 **cr mode
16588 C                 ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
16589 C   &                    (I.EQ.8).OR.(I.EQ.10)) THEN
16590 C                 ELSEIF (I.EQ.4) THEN
16591 C                    MDCY(KC,1) = 1
16592 **
16593                   ELSE
16594                      MDCY(KC,1) = 0
16595                   ENDIF
16596                ENDIF
16597             ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
16598
16599                KC = PYCOMP(IDXSTA(I))
16600
16601                IF (KC.GT.0) THEN
16602                   MDCY(KC,1) = 0
16603                ENDIF
16604             ENDIF
16605     1    CONTINUE
16606 *
16607
16608 * as Fluka event-generator: allow only paprop particles to be stable
16609 * and let all other particles decay (i.e. those with strong decays)
16610          IF (ITRSPT.EQ.1) THEN
16611             DO 5 I=1,IDMAXP
16612                IF (KPTOIP(I).NE.0) THEN
16613                   IDPDG = MPDGHA(I)
16614
16615                   KC    = PYCOMP(IDPDG)
16616
16617                   IF (KC.GT.0) THEN
16618                      IF (MDCY(KC,1).EQ.1) THEN
16619                         WRITE(LOUT,*)
16620      &                     ' DT_INITJS: Decay flag for FLUKA-',
16621      &                     'transport : particle should not ',
16622      &                     'decay : ',IDPDG,'  ',ANAME(I)
16623                         MDCY(KC,1) = 0
16624                      ENDIF
16625                   ENDIF
16626                ENDIF
16627     5       CONTINUE
16628             DO 6 KC=1,500
16629                IDPDG = KCHG(KC,4)
16630                KP    = MCIHAD(IDPDG)
16631                IF (KP.GT.0) THEN
16632                   IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND.
16633      &                (ANAME(KP).NE.'BLANK   ').AND.
16634      &                (ANAME(KP).NE.'RNDFLV  ')) THEN
16635                      WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
16636      &                             'transport: particle should decay ',
16637      &                             ': ',IDPDG,' ',ANAME(KP)
16638                      MDCY(KC,1) = 1
16639                   ENDIF
16640                ENDIF
16641     6       CONTINUE
16642          ENDIF
16643
16644 *
16645 * popcorn:
16646          IF (PDB.LE.ZERO) THEN
16647 *   no popcorn-mechanism
16648             MSTJ(12) = 1
16649          ELSE
16650             MSTJ(12) = 3
16651             PARJ(5)  = PDB
16652          ENDIF
16653 * set JETSET-parameter requested by input cards
16654          IF (NMSTU.GT.0) THEN
16655             DO 2 I=1,NMSTU
16656                MSTU(IMSTU(I)) = MSTUX(I)
16657     2       CONTINUE
16658          ENDIF
16659          IF (NMSTJ.GT.0) THEN
16660             DO 3 I=1,NMSTJ
16661                MSTJ(IMSTJ(I)) = MSTJX(I)
16662     3       CONTINUE
16663          ENDIF
16664          IF (NPARU.GT.0) THEN
16665             DO 4 I=1,NPARU
16666                PARU(IPARU(I)) = PARUX(I)
16667     4       CONTINUE
16668          ENDIF
16669          LFIRST = .FALSE.
16670       ENDIF
16671 *
16672 * PARJ(1)  suppression of qq-aqaq pair prod. compared to
16673 *          q-aq pair prod.                      (default: 0.1)
16674 * PARJ(2)  strangeness suppression               (default: 0.3)
16675 * PARJ(3)  extra suppression of strange diquarks (default: 0.4)
16676 * PARJ(6)  extra suppression of sas-pair shared by B and
16677 *          aB in BMaB                           (default: 0.5)
16678 * PARJ(7)  extra suppression of strange meson M in BMaB
16679 *          configuration                        (default: 0.5)
16680 * PARJ(18) spin 3/2 baryon suppression           (default: 1.0)
16681 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
16682 *          momentum distrib. for prim. hadrons  (default: 0.35)
16683 * PARJ(42) b-parameter for symmetric Lund-fragmentation
16684 *          function                             (default: 0.9 GeV^-2)
16685 *
16686 * PHOJET settings
16687       IF (MODE.EQ.1) THEN
16688 *   JETSET default
16689 C        PARJ(1)  = PDEF1
16690 C        PARJ(2)  = PDEF2
16691 C        PARJ(3)  = PDEF3
16692 C        PARJ(6)  = PDEF6
16693 C        PARJ(7)  = PDEF7
16694 C        PARJ(18) = PDEF18
16695 C        PARJ(21) = PDEF21
16696 C        PARJ(42) = PDEF42
16697 **sr 18.11.98 parameter tuning
16698 C        PARJ(1)  = 0.092D0
16699 C        PARJ(2)  = 0.25D0
16700 C        PARJ(3)  = 0.45D0
16701 C        PARJ(19) = 0.3D0
16702 C        PARJ(21) = 0.45D0
16703 C        PARJ(42) = 1.0D0
16704 **sr 28.04.99 parameter tuning (May 99 minor modifications)
16705          PARJ(1)  = 0.085D0
16706          PARJ(2)  = 0.26D0
16707          PARJ(3)  = 0.8D0
16708          PARJ(11) = 0.38D0
16709          PARJ(18) = 0.3D0
16710          PARJ(19) = 0.4D0
16711          PARJ(21) = 0.36D0
16712          PARJ(41) = 0.3D0
16713          PARJ(42) = 0.86D0
16714          IF (NPARJ.GT.0) THEN
16715             DO 10 I=1,NPARJ
16716                IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
16717    10       CONTINUE
16718          ENDIF
16719          IF (LFIRPH) THEN
16720             WRITE(LOUT,'(1X,A)')
16721      &         'DT_INITJS: JETSET-parameter for PHOJET'
16722             CALL DT_JSPARA(0)
16723             LFIRPH = .FALSE.
16724          ENDIF
16725 * DTUNUC settings
16726       ELSEIF (MODE.EQ.2) THEN
16727          IF (IFRAG(2).EQ.1) THEN
16728 **sr parameters before 9.3.96
16729 C           PARJ(2)  = 0.27D0
16730 C           PARJ(3)  = 0.6D0
16731 C           PARJ(6)  = 0.75D0
16732 C           PARJ(7)  = 0.75D0
16733 C           PARJ(21) = 0.55D0
16734 C           PARJ(42) = 1.3D0
16735 **sr 18.11.98 parameter tuning
16736 C           PARJ(1)  = 0.05D0
16737 C           PARJ(2)  = 0.27D0
16738 C           PARJ(3)  = 0.4D0
16739 C           PARJ(19) = 0.2D0
16740 C           PARJ(21) = 0.45D0
16741 C           PARJ(42) = 1.0D0
16742 **sr 28.04.99 parameter tuning
16743             PARJ(1)  = 0.11D0
16744             PARJ(2)  = 0.36D0
16745             PARJ(3)  = 0.8D0
16746             PARJ(19) = 0.2D0
16747             PARJ(21) = 0.3D0
16748             PARJ(41) = 0.3D0
16749             PARJ(42) = 0.58D0
16750             IF (NPARJ.GT.0) THEN
16751                DO 20 I=1,NPARJ
16752                   IF (IPARJ(I).LT.0) THEN
16753                      IDX = ABS(IPARJ(I))
16754                      PARJ(IDX) = PARJX(I)
16755                   ENDIF
16756    20          CONTINUE
16757             ENDIF
16758             IF (LFIRDT) THEN
16759                WRITE(LOUT,'(1X,A)')
16760      &           'DT_INITJS: JETSET-parameter for DTUNUC'
16761                CALL DT_JSPARA(0)
16762                LFIRDT = .FALSE.
16763             ENDIF
16764          ELSEIF (IFRAG(2).EQ.2) THEN
16765             PARJ(1)  = 0.11D0
16766             PARJ(2)  = 0.27D0
16767             PARJ(3)  = 0.3D0
16768             PARJ(6)  = 0.35D0
16769             PARJ(7)  = 0.45D0
16770             PARJ(18) = 0.66D0
16771 C           PARJ(21) = 0.55D0
16772 C           PARJ(42) = 1.0D0
16773             PARJ(21) = 0.60D0
16774             PARJ(42) = 1.3D0
16775          ELSE
16776             PARJ(1)  = PDEF1
16777             PARJ(2)  = PDEF2
16778             PARJ(3)  = PDEF3
16779             PARJ(6)  = PDEF6
16780             PARJ(7)  = PDEF7
16781             PARJ(18) = PDEF18
16782             PARJ(21) = PDEF21
16783             PARJ(42) = PDEF42
16784          ENDIF
16785       ELSE
16786          PARJ(1)  = PDEF1
16787          PARJ(2)  = PDEF2
16788          PARJ(3)  = PDEF3
16789          PARJ(5)  = PDEF5
16790          PARJ(6)  = PDEF6
16791          PARJ(7)  = PDEF7
16792          PARJ(18) = PDEF18
16793          PARJ(19) = PDEF19
16794          PARJ(21) = PDEF21
16795          PARJ(42) = PDEF42
16796          MSTJ(12) = MDEF12
16797       ENDIF
16798
16799       RETURN
16800       END
16801
16802 *$ CREATE DT_JSPARA.FOR
16803 *COPY DT_JSPARA
16804 *
16805 *===jspara=============================================================*
16806 *
16807       SUBROUTINE DT_JSPARA(MODE)
16808
16809       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16810       SAVE
16811
16812       PARAMETER ( LINP = 10 ,
16813      &            LOUT = 6 ,
16814      &            LDAT = 9 )
16815
16816       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
16817      &           ONE=1.0D0,ZERO=0.0D0)
16818
16819       LOGICAL LFIRST
16820
16821       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16822
16823       DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
16824
16825       DATA LFIRST /.TRUE./
16826
16827 * save the default JETSET-parameter on the first call
16828       IF (LFIRST) THEN
16829          DO 1 I=1,200
16830             ISTU(I) = MSTU(I)
16831             QARU(I) = PARU(I)
16832             ISTJ(I) = MSTJ(I)
16833             QARJ(I) = PARJ(I)
16834     1    CONTINUE
16835          LFIRST = .FALSE.
16836       ENDIF
16837
16838       WRITE(LOUT,1000)
16839  1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16840
16841 * compare the default JETSET-parameter with the present values
16842       DO 2 I=1,200
16843          IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16844             WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16845 C           ISTU(I) = MSTU(I)
16846          ENDIF
16847          DIFF = ABS(PARU(I)-QARU(I))
16848          IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16849             WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16850 C           QARU(I) = PARU(I)
16851          ENDIF
16852          IF (MSTJ(I).NE.ISTJ(I)) THEN
16853             WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16854 C           ISTJ(I) = MSTJ(I)
16855          ENDIF
16856          DIFF = ABS(PARJ(I)-QARJ(I))
16857          IF (DIFF.GE.1.0D-5) THEN
16858             WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16859 C           QARJ(I) = PARJ(I)
16860          ENDIF
16861     2 CONTINUE
16862  1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16863  1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16864
16865       RETURN
16866       END
16867 *$ CREATE DT_FOZOCA.FOR
16868 *COPY DT_FOZOCA
16869 *
16870 *===fozoca=============================================================*
16871 *
16872       SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16873
16874 ************************************************************************
16875 * This subroutine treats the complete FOrmation ZOne supressed intra-  *
16876 * nuclear CAscade.                                                     *
16877 *               LFZC = .true.  cascade has been treated                *
16878 *                    = .false. cascade skipped                         *
16879 * This is a completely revised version of the original FOZOKL.         *
16880 * This version dated 18.11.95 is written by S. Roesler                 *
16881 ************************************************************************
16882
16883       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16884       SAVE
16885
16886       PARAMETER ( LINP = 10 ,
16887      &            LOUT = 6 ,
16888      &            LDAT = 9 )
16889
16890       PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16891       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16892
16893       LOGICAL LSTART,LCAS,LFZC
16894
16895 * event history
16896
16897       PARAMETER (NMXHKK=200000)
16898
16899       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16900      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16901      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16902
16903 * extended event history
16904       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16905      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16906      &                IHIST(2,NMXHKK)
16907
16908 * rejection counter
16909       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16910      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16911      &                IREXCI(3),IRDIFF(2),IRINC
16912
16913 * properties of interacting particles
16914       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16915
16916 * Glauber formalism: collision properties
16917       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16918      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
16919      &                NCP,NCT
16920
16921 * flags for input different options
16922       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16923       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16924      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16925
16926 * final state after intranuclear cascade step
16927       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16928
16929 * parameter for intranuclear cascade
16930       LOGICAL LPAULI
16931       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16932
16933       DIMENSION NCWOUN(2)
16934
16935       DATA LSTART /.TRUE./
16936
16937       LFZC = .TRUE.
16938       IREJ = 0
16939
16940 * skip cascade if hadron-hadron interaction or if supressed by user
16941       IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16942 * skip cascade if not all possible chains systems are hadronized
16943       DO 1 I=1,8
16944          IF (.NOT.LHADRO(I)) GOTO 9999
16945     1 CONTINUE
16946
16947       IF (LSTART) THEN
16948          WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16949  1000    FORMAT(/,1X,'FOZOCA:  intranuclear cascade treated for a ',
16950      &          'maximum of',I4,' generations',/,10X,'formation time ',
16951      &          'parameter:',F5.1,'  fm/c',9X,'modus:',I2)
16952          IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16953          IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16954  1001    FORMAT(10X,'p_t dependent formation zone',/)
16955  1002    FORMAT(10X,'constant formation zone',/)
16956          LSTART = .FALSE.
16957       ENDIF
16958
16959 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16960 * which may interact with final state particles are stored in a seperate
16961 * array - here all proj./target nucleon-indices (just for simplicity)
16962       NOINC = 0
16963       DO 9 I=1,NPOINT(1)-1
16964          NOINC = NOINC+1
16965          IDXINC(NOINC) = I
16966     9 CONTINUE
16967
16968 * initialize Pauli-principle treatment (find wounded nucleons)
16969       NWOUND(1) = 0
16970       NWOUND(2) = 0
16971       NCWOUN(1) = 0
16972       NCWOUN(2) = 0
16973       DO 2 J=1,NPOINT(1)
16974          DO 3 I=1,2
16975             IF (ISTHKK(J).EQ.10+I) THEN
16976                NWOUND(I) = NWOUND(I)+1
16977                EWOUND(I,NWOUND(I)) = PHKK(4,J)
16978                IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16979             ENDIF
16980     3    CONTINUE
16981     2 CONTINUE
16982
16983 * modify nuclear potential for wounded nucleons
16984       IPRCL  = IP -NWOUND(1)
16985       IPZRCL = IPZ-NCWOUN(1)
16986       ITRCL  = IT -NWOUND(2)
16987       ITZRCL = ITZ-NCWOUN(2)
16988       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16989
16990       NSTART = NPOINT(4)
16991       NEND   = NHKK
16992
16993     7 CONTINUE
16994       DO 8 I=NSTART,NEND
16995
16996          IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16997 * select nucleus the cascade starts first (proj. - 1, target - -1)
16998             NCAS   = 1
16999 *   projectile/target with probab. 1/2
17000             IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
17001                IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
17002 *   in the nucleus with highest mass
17003             ELSEIF (INCMOD.EQ.2) THEN
17004                IF (IP.GT.IT) THEN
17005                   NCAS = -NCAS
17006                ELSEIF (IP.EQ.IT) THEN
17007                   IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
17008                ENDIF
17009 * the nucleus the cascade starts first is requested to be the one
17010 * moving in the direction of the secondary
17011             ELSEIF (INCMOD.EQ.3) THEN
17012                NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
17013             ENDIF
17014 * check that the selected "nucleus" is not a hadron
17015             IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
17016      &          ((NCAS.EQ.-1).AND.(IT.LE.1)))    NCAS = -NCAS
17017
17018 * treat intranuclear cascade in the nucleus selected first
17019             LCAS = .FALSE.
17020             CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17021             IF (IREJ1.NE.0) GOTO 9998
17022 * treat intranuclear cascade in the other nucleus if this isn't a had.
17023             NCAS = -NCAS
17024             IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
17025      &          ((NCAS.EQ.-1).AND.(IT.GT.1)))    THEN
17026                IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17027                IF (IREJ1.NE.0) GOTO 9998
17028             ENDIF
17029
17030          ENDIF
17031
17032     8 CONTINUE
17033       NSTART = NEND+1
17034       NEND   = NHKK
17035       IF (NSTART.LE.NEND) GOTO 7
17036
17037       RETURN
17038
17039  9998 CONTINUE
17040 * reject this event
17041       IRINC = IRINC+1
17042       IREJ = 1
17043
17044  9999 CONTINUE
17045 * intranucl. cascade not treated because of interaction properties or
17046 * it is supressed by user or it was rejected or...
17047       LFZC = .FALSE.
17048 * reset flag characterizing direction of motion in n-n-cms
17049 **sr14-11-95
17050 C     DO 9990 I=NPOINT(5),NHKK
17051 C        IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
17052 C9990 CONTINUE
17053
17054       RETURN
17055       END
17056
17057 *$ CREATE DT_INUCAS.FOR
17058 *COPY DT_INUCAS
17059 *
17060 *===inucas=============================================================*
17061 *
17062       SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
17063
17064 ************************************************************************
17065 * Formation zone supressed IntraNUclear CAScade for one final state    *
17066 * particle.                                                            *
17067 *           IT, IP    mass numbers of target, projectile nuclei        *
17068 *           IDXCAS    index of final state particle in DTEVT1          *
17069 *           NCAS =  1 intranuclear cascade in projectile               *
17070 *                = -1 intranuclear cascade in target                   *
17071 * This version dated 18.11.95 is written by S. Roesler                 *
17072 ************************************************************************
17073
17074       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17075       SAVE
17076
17077       PARAMETER ( LINP = 10 ,
17078      &            LOUT = 6 ,
17079      &            LDAT = 9 )
17080
17081       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
17082      &           OHALF=0.5D0,ONE=1.0D0)
17083       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
17084       PARAMETER (TWOPI=6.283185307179586454D+00)
17085       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
17086
17087       LOGICAL LABSOR,LCAS
17088
17089 * event history
17090
17091       PARAMETER (NMXHKK=200000)
17092
17093       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17094      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17095      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17096
17097 * extended event history
17098       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17099      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17100      &                IHIST(2,NMXHKK)
17101
17102 * final state after inc step
17103       PARAMETER (MAXFSP=10)
17104       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17105
17106 * flags for input different options
17107       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17108       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17109      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17110
17111 * particle properties (BAMJET index convention)
17112       CHARACTER*8  ANAME
17113       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17114      &                IICH(210),IIBAR(210),K1(210),K2(210)
17115
17116 * Glauber formalism: collision properties
17117       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
17118      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
17119      &                NCP,NCT
17120 * nuclear potential
17121       LOGICAL LFERMI
17122       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17123      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17124      &                ETACOU(2),ICOUL,LFERMI
17125
17126 * parameter for intranuclear cascade
17127       LOGICAL LPAULI
17128       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17129
17130 * final state after intranuclear cascade step
17131       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
17132
17133 * nucleon-nucleon event-generator
17134       CHARACTER*8 CMODEL
17135       LOGICAL LPHOIN
17136       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
17137
17138 * statistics: residual nuclei
17139       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
17140      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
17141      &                NINCST(2,4),NINCEV(2),
17142      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
17143      &                NRESPB(2),NRESCH(2),NRESEV(4),
17144      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
17145      &                NEVAFI(2,2)
17146
17147       DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
17148      &          PCAS1(5),PNUC(5),BGTA(4),
17149      &          BGCAS(2),GACAS(2),BECAS(2),
17150      &          RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
17151
17152       DATA PDIF /0.545D0/
17153
17154       IREJ = 0
17155
17156 * update counter
17157       IF (NINCEV(1).NE.NEVHKK) THEN
17158          NINCEV(1) = NEVHKK
17159          NINCEV(2) = NINCEV(2)+1
17160       ENDIF
17161
17162 * "BAMJET-index" of this hadron
17163       IDCAS = IDBAM(IDXCAS)
17164       IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
17165
17166 * skip gammas, electrons, etc..
17167       IF (AAM(IDCAS).LT.TINY2) RETURN
17168
17169 * Lorentz-trsf. into projectile rest system
17170       IF (IP.GT.1) THEN
17171          CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17172      &               PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
17173      &               PCAS(1,4),IDCAS,-2)
17174          PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
17175          PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
17176          IF (PCAS(1,5).GT.ZERO) THEN
17177             PCAS(1,5) = SQRT(PCAS(1,5))
17178          ELSE
17179             PCAS(1,5) = AAM(IDCAS)
17180          ENDIF
17181          DO 20 K=1,3
17182             COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
17183    20    CONTINUE
17184 * Lorentz-parameters
17185 *   particle rest system --> projectile rest system
17186          BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
17187          GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
17188          BECAS(1) = BGCAS(1)/GACAS(1)
17189       ELSE
17190          DO 21 K=1,5
17191             PCAS(1,K) = ZERO
17192             IF (K.LE.3) COSCAS(1,K) = ZERO
17193    21    CONTINUE
17194          PTOCAS(1) = ZERO
17195          BGCAS(1)  = ZERO
17196          GACAS(1)  = ZERO
17197          BECAS(1)  = ZERO
17198       ENDIF
17199 * Lorentz-trsf. into target rest system
17200       IF (IT.GT.1) THEN
17201 * LEPTO: final state particles are already in target rest frame
17202 C        IF (MCGENE.EQ.3) THEN
17203 C           PCAS(2,1) = PHKK(1,IDXCAS)
17204 C           PCAS(2,2) = PHKK(2,IDXCAS)
17205 C           PCAS(2,3) = PHKK(3,IDXCAS)
17206 C           PCAS(2,4) = PHKK(4,IDXCAS)
17207 C        ELSE
17208             CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17209      &                  PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
17210      &                  PCAS(2,4),IDCAS,-3)
17211 C        ENDIF
17212          PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
17213          PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
17214          IF (PCAS(2,5).GT.ZERO) THEN
17215             PCAS(2,5) = SQRT(PCAS(2,5))
17216          ELSE
17217             PCAS(2,5) = AAM(IDCAS)
17218          ENDIF
17219          DO 22 K=1,3
17220             COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
17221    22    CONTINUE
17222 * Lorentz-parameters
17223 *   particle rest system --> target rest system
17224          BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
17225          GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
17226          BECAS(2) = BGCAS(2)/GACAS(2)
17227       ELSE
17228          DO 23 K=1,5
17229             PCAS(2,K) = ZERO
17230             IF (K.LE.3) COSCAS(2,K) = ZERO
17231    23    CONTINUE
17232          PTOCAS(2) = ZERO
17233          BGCAS(2)  = ZERO
17234          GACAS(2)  = ZERO
17235          BECAS(2)  = ZERO
17236       ENDIF
17237
17238 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
17239 * potential (see CONUCL)
17240       RNUC(1)  = (RPROJ+4.605D0*PDIF)*FM2MM
17241       RNUC(2)  = (RTARG+4.605D0*PDIF)*FM2MM
17242 * impact parameter (the projectile moving along z)
17243       BIMPC(1) = ZERO
17244       BIMPC(2) = BIMPAC*FM2MM
17245
17246 * get position of initial hadron in projectile/target rest-syst.
17247       DO 3 K=1,4
17248          VTXCAS(1,K) = WHKK(K,IDXCAS)
17249          VTXCAS(2,K) = VHKK(K,IDXCAS)
17250     3 CONTINUE
17251
17252       ICAS = 1
17253       I2   = 2
17254       IF (NCAS.EQ.-1) THEN
17255          ICAS = 2
17256          I2   = 1
17257       ENDIF
17258
17259       IF (PTOCAS(ICAS).LT.TINY10) THEN
17260          WRITE(LOUT,1000) PTOCAS
17261  1000    FORMAT(1X,'INUCAS:   warning! zero momentum of initial',
17262      &          '  hadron ',/,20X,2E12.4)
17263          GOTO 9999
17264       ENDIF
17265
17266 * reset spectator flags
17267       NSPE = 0
17268       IDXSPE(1) = 0
17269       IDXSPE(2) = 0
17270       IDSPE(1)  = 0
17271       IDSPE(2)  = 0
17272
17273 * formation length (in fm)
17274 C     IF (LCAS) THEN
17275 C        DEL0 = ZERO
17276 C     ELSE
17277          DEL0 = TAUFOR*BGCAS(ICAS)
17278          IF (ITAUVE.EQ.1) THEN
17279             AMT  = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
17280             DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
17281          ENDIF
17282 C     ENDIF
17283 *   sample from exp(-del/del0)
17284       DEL1   = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
17285 * save formation time
17286       TAUSA1 = DEL1/BGCAS(ICAS)
17287       REL1   = TAUSA1*BGCAS(I2)
17288
17289       DEL    = DEL1
17290       TAUSAM = DEL/BGCAS(ICAS)
17291       REL    = TAUSAM*BGCAS(I2)
17292
17293 * special treatment for negative particles unable to escape
17294 * nuclear potential (implemented for ap, pi-, K- only)
17295       LABSOR = .FALSE.
17296       IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
17297 *   threshold energy = nuclear potential + Coulomb potential
17298 *   (nuclear potential for hadron-nucleus interactions only)
17299          ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
17300          IF (PCAS(ICAS,4).LT.ETHR) THEN
17301             DO 4 K=1,5
17302                PCAS1(K) = PCAS(ICAS,K)
17303     4       CONTINUE
17304 *   "absorb" negative particle in nucleus
17305             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
17306             IF (IREJ1.NE.0) GOTO 9999
17307             IF (NSPE.GE.1) LABSOR = .TRUE.
17308          ENDIF
17309       ENDIF
17310
17311 * if the initial particle has not been absorbed proceed with
17312 * "normal" cascade
17313       IF (.NOT.LABSOR) THEN
17314
17315 *   calculate coordinates of hadron at the end of the formation zone
17316 *   transport-time and -step in the rest system where this step is
17317 *   treated
17318          DSTEP  = DEL*FM2MM
17319          DTIME  = DSTEP/BECAS(ICAS)
17320          RSTEP  = REL*FM2MM
17321          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17322             RTIME = RSTEP/BECAS(I2)
17323          ELSE
17324             RTIME = ZERO
17325          ENDIF
17326 *   save step whithout considering the overlapping region
17327          DSTEP1 = DEL1*FM2MM
17328          DTIME1 = DSTEP1/BECAS(ICAS)
17329          RSTEP1 = REL1*FM2MM
17330          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17331             RTIME1 = RSTEP1/BECAS(I2)
17332          ELSE
17333             RTIME1 = ZERO
17334          ENDIF
17335 *   transport to the end of the formation zone in this system
17336          DO 5 K=1,3
17337             VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
17338             VTXCA1(I2,K)   = VTXCAS(I2,K)  +RSTEP1*COSCAS(I2,K)
17339             VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
17340             VTXCAS(I2,K)   = VTXCAS(I2,K)  +RSTEP*COSCAS(I2,K)
17341     5    CONTINUE
17342          VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
17343          VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME1
17344          VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17345          VTXCAS(I2,4)   = VTXCAS(I2,4)  +RTIME
17346
17347          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17348             XCAS   = VTXCAS(ICAS,1)
17349             YCAS   = VTXCAS(ICAS,2)
17350             XNCLTA = BIMPAC*FM2MM
17351             RNCLPR = (RPROJ+RNUCLE)*FM2MM
17352             RNCLTA = (RTARG+RNUCLE)*FM2MM
17353 C           RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
17354 C           RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
17355 C           RNCLPR = (RPROJ)*FM2MM
17356 C           RNCLTA = (RTARG)*FM2MM
17357             RCASPR = SQRT( XCAS**2        +YCAS**2)
17358             RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
17359             IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
17360                IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
17361             ENDIF
17362          ENDIF
17363
17364 *   check if particle is already outside of the corresp. nucleus
17365          RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
17366      &                VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
17367          IF (RDIST.GE.RNUC(ICAS)) THEN
17368 *   here: IDCH is the generation of the final state part. starting
17369 *   with zero for hadronization products
17370 *   flag particles of generation 0 being outside the nuclei after
17371 *   formation time (to be used for excitation energy calculation)
17372             IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
17373      &         NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
17374             GOTO 9997
17375          ENDIF
17376          DIST   = DLARGE
17377          DISTP  = DLARGE
17378          DISTN  = DLARGE
17379          IDXP   = 0
17380          IDXN   = 0
17381
17382 *   already here: skip particles being outside HADRIN "energy-window"
17383 *   to avoid wasting of time
17384          NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
17385          IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
17386             NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
17387 C           WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
17388 C1002       FORMAT(1X,'INUCAS:   warning! momentum of particle with ',
17389 C    &             'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
17390 C    &             E12.4,', above or below HADRIN-thresholds',I6)
17391             NSPE = 0
17392             GOTO 9997
17393          ENDIF
17394
17395          DO 7 IDXHKK=1,NOINC
17396             I = IDXINC(IDXHKK)
17397 *   scan DTEVT1 for unwounded or excited nucleons
17398             IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
17399                DO 8 K=1,3
17400                   IF (ICAS.EQ.1) THEN
17401                      VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
17402                   ELSEIF (ICAS.EQ.2) THEN
17403                      VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
17404                   ENDIF
17405     8          CONTINUE
17406                POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
17407      &                  VTXDST(2)*COSCAS(ICAS,2)+
17408      &                  VTXDST(3)*COSCAS(ICAS,3)
17409 *   check if nucleon is situated in forward direction
17410                IF (POSNUC.GT.ZERO) THEN
17411 *   distance between hadron and this nucleon
17412                   DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17413      &                          VTXDST(3)**2)
17414 *   impact parameter
17415                   BIMNU2 = DISTNU**2-POSNUC**2
17416                   IF (BIMNU2.LT.ZERO) THEN
17417                      WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
17418  1001                FORMAT(1X,'INUCAS:   warning! inconsistent impact',
17419      &                      '  parameter ',/,20X,3E12.4)
17420                      GOTO 7
17421                   ENDIF
17422                   BIMNU  = SQRT(BIMNU2)
17423 *   maximum impact parameter to have interaction
17424                   IDNUC  = IDT_ICIHAD(IDHKK(I))
17425                   IDNUC1 = IDT_MCHAD(IDNUC)
17426                   IDCAS1 = IDT_MCHAD(IDCAS)
17427                   DO 19 K=1,5
17428                      PCAS1(K) = PCAS(ICAS,K)
17429                      PNUC(K)  = PHKK(K,I)
17430    19             CONTINUE
17431 * Lorentz-parameter for trafo into rest-system of target
17432                   DO 18 K=1,4
17433                      BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
17434    18             CONTINUE
17435 * transformation of projectile into rest-system of target
17436                   CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
17437      &                        PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
17438      &                        PPTOT,PX,PY,PZ,PE)
17439 **
17440 C                 CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
17441 C                 CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
17442                   DUMZER = ZERO
17443                   CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
17444                   CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
17445                   IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
17446      &                (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
17447                   SIGIN = SIGTOT-SIGEL-SIGAB
17448 C                 SIGTOT = SIGIN+SIGEL+SIGAB
17449 **
17450                   BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
17451 *   check if interaction is possible
17452                   IF (BIMNU.LE.BIMMAX) THEN
17453 *   get nucleon with smallest distance and kind of interaction
17454 *   (elastic/inelastic)
17455                      IF (DISTNU.LT.DIST) THEN
17456                         DIST      = DISTNU
17457                         BINT      = BIMNU
17458                         IF (IDNUC.NE.IDSPE(1)) THEN
17459                            IDSPE(2)  = IDSPE(1)
17460                            IDXSPE(2) = IDXSPE(1)
17461                            IDSPE(1)  = IDNUC
17462                         ENDIF
17463                         IDXSPE(1) = I
17464                         NSPE      = 1
17465 **sr
17466                         SELA = SIGEL
17467                         SABS = SIGAB
17468                         STOT = SIGTOT
17469 C                       IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
17470 C                          SELA = SIGEL
17471 C                          STOT = SIGIN+SIGEL
17472 C                       ELSE
17473 C                          SELA = SIGEL+0.75D0*SIGIN
17474 C                          STOT = 0.25D0*SIGIN+SELA
17475 C                       ENDIF
17476 **
17477                      ENDIF
17478                   ENDIf
17479                ENDIF
17480                DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17481      &                       VTXDST(3)**2)
17482                IDNUC  = IDT_ICIHAD(IDHKK(I))
17483                IF (IDNUC.EQ.1) THEN
17484                   IF (DISTNU.LT.DISTP) THEN
17485                      DISTP = DISTNU
17486                      IDXP  = I
17487                      POSP  = POSNUC
17488                   ENDIF
17489                ELSEIF (IDNUC.EQ.8) THEN
17490                   IF (DISTNU.LT.DISTN) THEN
17491                      DISTN = DISTNU
17492                      IDXN  = I
17493                      POSN  = POSNUC
17494                   ENDIF
17495                ENDIF
17496             ENDIF
17497     7    CONTINUE
17498
17499 * there is no nucleon for a secondary interaction
17500          IF (NSPE.EQ.0) GOTO 9997
17501
17502 C        IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
17503 C    &      WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
17504          IF (IDXSPE(2).EQ.0) THEN
17505             IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
17506 C              DO 80 K=1,3
17507 C                 IF (ICAS.EQ.1) THEN
17508 C                    VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
17509 C                 ELSEIF (ICAS.EQ.2) THEN
17510 C                    VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
17511 C                 ENDIF
17512 C  80          CONTINUE
17513 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17514 C    &                       VTXDST(3)**2)
17515 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
17516                   IDXSPE(2) = IDXN
17517                   IDSPE(2)  = 8
17518 C              ELSE
17519 C                 STOT = STOT-SABS
17520 C                 SABS = ZERO
17521 C              ENDIF
17522             ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
17523 C              DO 81 K=1,3
17524 C                 IF (ICAS.EQ.1) THEN
17525 C                    VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
17526 C                 ELSEIF (ICAS.EQ.2) THEN
17527 C                    VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
17528 C                 ENDIF
17529 C  81          CONTINUE
17530 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17531 C    &                       VTXDST(3)**2)
17532 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
17533                   IDXSPE(2) = IDXP
17534                   IDSPE(2)  = 1
17535 C              ELSE
17536 C                 STOT = STOT-SABS
17537 C                 SABS = ZERO
17538 C              ENDIF
17539             ELSE
17540                STOT = STOT-SABS
17541                SABS = ZERO
17542             ENDIF
17543          ENDIF
17544          RR = DT_RNDM(DIST)
17545          IF (RR.LT.SELA/STOT) THEN
17546             IPROC = 2
17547          ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
17548             IPROC = 3
17549          ELSE
17550             IPROC = 1
17551          ENDIF
17552
17553          DO 9 K=1,5
17554             PCAS1(K) = PCAS(ICAS,K)
17555             PNUC(K)  = PHKK(K,IDXSPE(1))
17556     9    CONTINUE
17557          IF (IPROC.EQ.3) THEN
17558 * 2-nucleon absorption of pion
17559             NSPE = 2
17560             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
17561             IF (IREJ1.NE.0) GOTO 9999
17562             IF (NSPE.GE.1) LABSOR = .TRUE.
17563          ELSE
17564 * sample secondary interaction
17565             IDNUC = IDBAM(IDXSPE(1))
17566             CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
17567             IF (IREJ1.EQ.1) GOTO 9999
17568             IF (IREJ1.GT.1) GOTO 9998
17569          ENDIF
17570       ENDIF
17571
17572 * update arrays to include Pauli-principle
17573       DO 10 I=1,NSPE
17574          IF (NWOUND(ICAS).LE.299) THEN
17575             NWOUND(ICAS) = NWOUND(ICAS)+1
17576             EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
17577          ENDIF
17578    10 CONTINUE
17579
17580 * dump initial hadron for energy-momentum conservation check
17581       IF (LEMCCK)
17582      &   CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
17583      &               PCAS(ICAS,4),1,IDUM,IDUM)
17584
17585 * dump final state particles into DTEVT1
17586
17587 *   check if Pauli-principle is fulfilled
17588       NPAULI = 0
17589       NWTMP(1) = NWOUND(1)
17590       NWTMP(2) = NWOUND(2)
17591       DO 111 I=1,NFSP
17592          NPAULI = 0
17593          J1 = 2
17594          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17595      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
17596          DO 117 J=1,J1
17597             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
17598             IF (J.EQ.1) THEN
17599                IDX = ICAS
17600                PE  = PFSP(4,I)
17601             ELSE
17602                IDX  = I2
17603                MODE = 1
17604                IF (IDX.EQ.1) MODE = -1
17605                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
17606             ENDIF
17607 * first check if cascade step is forbidden due to Pauli-principle
17608 * (in case of absorpion this step is forced)
17609             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17610      &          (IDFSP(I).EQ.8))) THEN
17611 *   get nuclear potential barrier
17612                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17613                IF (IDFSP(I).EQ.1) THEN
17614                   POTLOW = POT-EBINDP(IDX)
17615                ELSE
17616                   POTLOW = POT-EBINDN(IDX)
17617                ENDIF
17618 *   final state particle not able to escape nucleus
17619                IF (PE.LE.POTLOW) THEN
17620 *     check if there are wounded nucleons
17621                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17622      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
17623                      NPAULI      = NPAULI+1
17624                      NWOUND(IDX) = NWOUND(IDX)-1
17625                   ELSE
17626 *     interaction prohibited by Pauli-principle
17627                      NWOUND(1) = NWTMP(1)
17628                      NWOUND(2) = NWTMP(2)
17629                      GOTO 9997
17630                   ENDIF
17631                ENDIF
17632             ENDIF
17633   117    CONTINUE
17634   111 CONTINUE
17635
17636       NPAULI = 0
17637       NWOUND(1) = NWTMP(1)
17638       NWOUND(2) = NWTMP(2)
17639
17640       DO 11 I=1,NFSP
17641
17642          IST = ISTHKK(IDXCAS)
17643
17644          NPAULI = 0
17645          J1 = 2
17646          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17647      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
17648          DO 17 J=1,J1
17649             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
17650             IDX = ICAS
17651             PE  = PFSP(4,I)
17652             IF (J.EQ.2) THEN
17653                IDX = I2
17654                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
17655             ENDIF
17656 * first check if cascade step is forbidden due to Pauli-principle
17657 * (in case of absorpion this step is forced)
17658             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17659      &          (IDFSP(I).EQ.8))) THEN
17660 *   get nuclear potential barrier
17661                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17662                IF (IDFSP(I).EQ.1) THEN
17663                   POTLOW = POT-EBINDP(IDX)
17664                ELSE
17665                   POTLOW = POT-EBINDN(IDX)
17666                ENDIF
17667 *   final state particle not able to escape nucleus
17668                IF (PE.LE.POTLOW) THEN
17669 *     check if there are wounded nucleons
17670                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17671      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
17672                      NWOUND(IDX) = NWOUND(IDX)-1
17673                      NPAULI = NPAULI+1
17674                      IST    = 14+IDX
17675                   ELSE
17676 *     interaction prohibited by Pauli-principle
17677                      NWOUND(1) = NWTMP(1)
17678                      NWOUND(2) = NWTMP(2)
17679                      GOTO 9997
17680                   ENDIF
17681 **sr
17682 c               ELSEIF (PE.LE.POT) THEN
17683 cC              ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
17684 cC                 NWOUND(IDX) = NWOUND(IDX)-1
17685 c**
17686 c                  NPAULI = NPAULI+1
17687 c                  IST    = 14+IDX
17688                ENDIF
17689             ENDIF
17690    17    CONTINUE
17691
17692 * dump final state particles for energy-momentum conservation check
17693          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
17694      &                           -PFSP(4,I),2,IDUM,IDUM)
17695
17696          PX = PFSP(1,I)
17697          PY = PFSP(2,I)
17698          PZ = PFSP(3,I)
17699          PE = PFSP(4,I)
17700          IF (ABS(IST).EQ.1) THEN
17701 * transform particles back into n-n cms
17702 * LEPTO: leave final state particles in target rest frame
17703 C           IF (MCGENE.EQ.3) THEN
17704 C              PFSP(1,I) = PX
17705 C              PFSP(2,I) = PY
17706 C              PFSP(3,I) = PZ
17707 C              PFSP(4,I) = PE
17708 C           ELSE
17709                IMODE = ICAS+1
17710                CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17711      &                     PFSP(4,I),IDFSP(I),IMODE)
17712 C           ENDIF
17713          ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
17714 * target cascade but fsp got stuck in proj. --> transform it into
17715 * proj. rest system
17716             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17717      &                  PFSP(4,I),IDFSP(I),-1)
17718          ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
17719 * proj. cascade but fsp got stuck in target --> transform it into
17720 * target rest system
17721             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17722      &                  PFSP(4,I),IDFSP(I),1)
17723          ENDIF
17724
17725 * dump final state particles into DTEVT1
17726          IGEN = IDCH(IDXCAS)+1
17727          ID   = IDT_IPDGHA(IDFSP(I))
17728          IXR  = 0
17729          IF (LABSOR) IXR = 99
17730          CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
17731      &               PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
17732
17733 * update the counter for particles which got stuck inside the nucleus
17734          IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
17735             NOINC = NOINC+1
17736             IDXINC(NOINC) = NHKK
17737          ENDIF
17738          IF (LABSOR) THEN
17739 *   in case of absorption the spatial treatment is an approximate
17740 *   solution anyway (the positions of the nucleons which "absorb" the
17741 *   cascade particle are not taken into consideration) therefore the
17742 *   particles are produced at the position of the cascade particle
17743             DO 12 K=1,4
17744                WHKK(K,NHKK) = WHKK(K,IDXCAS)
17745                VHKK(K,NHKK) = VHKK(K,IDXCAS)
17746    12       CONTINUE
17747          ELSE
17748 *   DDISTL - distance the cascade particle moves to the intera. point
17749 *   (the position where impact-parameter = distance to the interacting
17750 *   nucleon), DIST - distance to the interacting nucleon at the time of
17751 *   formation of the cascade particle, BINT - impact-parameter of this
17752 *   cascade-interaction
17753             DDISTL = SQRT(DIST**2-BINT**2)
17754             DTIME  = DDISTL/BECAS(ICAS)
17755             DTIMEL = DDISTL/BGCAS(ICAS)
17756             RDISTL = DTIMEL*BGCAS(I2)
17757             IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17758                RTIME = RDISTL/BECAS(I2)
17759             ELSE
17760                RTIME = ZERO
17761             ENDIF
17762 *   RDISTL, RTIME are this step and time in the rest system of the other
17763 *   nucleus
17764             DO 13 K=1,3
17765                VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
17766                VTXCA1(I2,K)   = VTXCAS(I2,K)  +COSCAS(I2,K)  *RDISTL
17767    13       CONTINUE
17768             VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17769             VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME
17770 *   position of particle production is half the impact-parameter to
17771 *   the interacting nucleon
17772             DO 14 K=1,3
17773                WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
17774                VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
17775    14       CONTINUE
17776 *   time of production of secondary = time of interaction
17777             WHKK(4,NHKK) = VTXCA1(1,4)
17778             VHKK(4,NHKK) = VTXCA1(2,4)
17779          ENDIF
17780
17781    11 CONTINUE
17782
17783 * modify status and position of cascade particle (the latter for
17784 * statistics reasons only)
17785       ISTHKK(IDXCAS) = 2
17786       IF (LABSOR) ISTHKK(IDXCAS) = 19
17787       IF (.NOT.LABSOR) THEN
17788          DO 15 K=1,4
17789             WHKK(K,IDXCAS) = VTXCA1(1,K)
17790             VHKK(K,IDXCAS) = VTXCA1(2,K)
17791    15    CONTINUE
17792       ENDIF
17793
17794       DO 16 I=1,NSPE
17795          IS = IDXSPE(I)
17796 * dump interacting nucleons for energy-momentum conservation check
17797          IF (LEMCCK)
17798      &      CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
17799      &                                                  2,IDUM,IDUM)
17800 * modify entry for interacting nucleons
17801          IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
17802          IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
17803          IF (I.GE.2) THEN
17804             JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
17805             JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
17806          ENDIF
17807    16 CONTINUE
17808
17809 * check energy-momentum conservation
17810       IF (LEMCCK) THEN
17811          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
17812          IF (IREJ1.NE.0) GOTO 9999
17813       ENDIF
17814
17815 * update counter
17816       IF (LABSOR) THEN
17817          NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
17818       ELSE
17819          IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
17820          IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
17821       ENDIF
17822
17823       RETURN
17824
17825  9997 CONTINUE
17826  9998 CONTINUE
17827 * transport-step but no cascade step due to configuration (i.e. there
17828 * is no nucleon for interaction etc.)
17829       IF (LCAS) THEN
17830          DO 100 K=1,4
17831 C           WHKK(K,IDXCAS) = VTXCAS(1,K)
17832 C           VHKK(K,IDXCAS) = VTXCAS(2,K)
17833             WHKK(K,IDXCAS) = VTXCA1(1,K)
17834             VHKK(K,IDXCAS) = VTXCA1(2,K)
17835   100    CONTINUE
17836       ENDIF
17837
17838 C9998 CONTINUE
17839 * no cascade-step because of configuration
17840 * (i.e. hadron outside nucleus etc.)
17841       LCAS = .TRUE.
17842       RETURN
17843
17844  9999 CONTINUE
17845 * rejection
17846       IREJ = 1
17847       RETURN
17848       END
17849
17850 *$ CREATE DT_ABSORP.FOR
17851 *COPY DT_ABSORP
17852 *
17853 *===absorp=============================================================*
17854 *
17855       SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
17856
17857 ************************************************************************
17858 * Two-nucleon absorption of antiprotons, pi-, and K-.                  *
17859 * Antiproton absorption is handled by HADRIN.                          *
17860 * The following channels for meson-absorption are considered:          *
17861 *          pi- + p + p ---> n + p                                      *
17862 *          pi- + p + n ---> n + n                                      *
17863 *          K-  + p + p ---> sigma+ + n / Lam + p / sigma0 + p          *
17864 *          K-  + p + n ---> sigma- + n / Lam + n / sigma0 + n          *
17865 *          K-  + p + p ---> sigma- + n                                 *
17866 *      IDCAS, PCAS   identity, momentum of particle to be absorbed     *
17867 *      NCAS =  1     intranuclear cascade in projectile                *
17868 *           = -1     intranuclear cascade in target                    *
17869 *      NSPE          number of spectator nucleons involved             *
17870 *      IDXSPE(2)     DTEVT1-indices of spectator nucleons involved     *
17871 * Revised version of the original STOPIK written by HJM and J. Ranft.  *
17872 * This version dated 24.02.95 is written by S. Roesler                 *
17873 ************************************************************************
17874
17875       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17876       SAVE
17877
17878       PARAMETER ( LINP = 10 ,
17879      &            LOUT = 6 ,
17880      &            LDAT = 9 )
17881
17882       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17883      &           ONETHI=0.3333D0,TWOTHI=0.6666D0)
17884
17885 * event history
17886
17887       PARAMETER (NMXHKK=200000)
17888
17889       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17890      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17891      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17892
17893 * extended event history
17894       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17895      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17896      &                IHIST(2,NMXHKK)
17897
17898 * flags for input different options
17899       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17900       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17901      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17902
17903 * final state after inc step
17904       PARAMETER (MAXFSP=10)
17905       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17906
17907 * particle properties (BAMJET index convention)
17908       CHARACTER*8  ANAME
17909       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17910      &                IICH(210),IIBAR(210),K1(210),K2(210)
17911
17912       DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17913      &          PTOT3P(4),BG3P(4),
17914      &          ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17915
17916       IREJ = 0
17917       NFSP = 0
17918
17919 * skip particles others than ap, pi-, K- for mode=0
17920       IF ((MODE.EQ.0).AND.
17921      &    (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17922 * skip particles others than pions for mode=1
17923 * (2-nucleon absorption in intranuclear cascade)
17924       IF ((MODE.EQ.1).AND.
17925      &    (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17926
17927       NUCAS = NCAS
17928       IF (NUCAS.EQ.-1) NUCAS = 2
17929
17930       IF (MODE.EQ.0) THEN
17931 * scan spectator nucleons for nucleons being able to "absorb"
17932          NSPE      = 0
17933          IDXSPE(1) = 0
17934          IDXSPE(2) = 0
17935          DO 1 I=1,NHKK
17936             IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17937                NSPE         = NSPE+1
17938                IDXSPE(NSPE) = I
17939                IDSPE(NSPE)  = IDBAM(I)
17940                IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17941                IF (NSPE.EQ.2) THEN
17942                   IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17943      &                                  (IDSPE(2).EQ.8)) THEN
17944 *    there is no pi-+n+n channel
17945                      NSPE = 1
17946                      GOTO 1
17947                   ELSE
17948                      GOTO 2
17949                   ENDIF
17950                ENDIF
17951             ENDIF
17952     1    CONTINUE
17953
17954     2    CONTINUE
17955       ENDIF
17956 * transform excited projectile nucleons (status=15) into proj. rest s.
17957       DO 3 I=1,NSPE
17958          DO 4 K=1,5
17959             PSPE(I,K) = PHKK(K,IDXSPE(I))
17960     4    CONTINUE
17961     3 CONTINUE
17962
17963 * antiproton absorption
17964       IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17965          DO 5 K=1,5
17966             PSPE1(K) = PSPE(1,K)
17967     5    CONTINUE
17968          CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17969          IF (IREJ1.NE.0) GOTO 9999
17970
17971 * meson absorption
17972       ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17973      &                      .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17974          IF (IDCAS.EQ.14) THEN
17975 *   pi- absorption
17976             IDFSP(1) = 8
17977             IDFSP(2) = 8
17978             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17979          ELSEIF (IDCAS.EQ.13) THEN
17980 *   pi+ absorption
17981             IDFSP(1) = 1
17982             IDFSP(2) = 1
17983             IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17984          ELSEIF (IDCAS.EQ.23) THEN
17985 *   pi0 absorption
17986             IDFSP(1) = IDSPE(1)
17987             IDFSP(2) = IDSPE(2)
17988          ELSEIF (IDCAS.EQ.16) THEN
17989 *   K- absorption
17990             R = DT_RNDM(PCAS)
17991             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17992                IF (R.LT.ONETHI) THEN
17993                   IDFSP(1) = 21
17994                   IDFSP(2) = 8
17995                ELSEIF (R.LT.TWOTHI) THEN
17996                   IDFSP(1) = 17
17997                   IDFSP(2) = 1
17998                ELSE
17999                   IDFSP(1) = 22
18000                   IDFSP(2) = 1
18001                ENDIF
18002             ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
18003                IDFSP(1) = 20
18004                IDFSP(2) = 8
18005             ELSE
18006                IF (R.LT.ONETHI) THEN
18007                   IDFSP(1) = 20
18008                   IDFSP(2) = 1
18009                ELSEIF (R.LT.TWOTHI) THEN
18010                   IDFSP(1) = 17
18011                   IDFSP(2) = 8
18012                ELSE
18013                   IDFSP(1) = 22
18014                   IDFSP(2) = 8
18015                ENDIF
18016             ENDIF
18017          ENDIF
18018 *   dump initial particles for energy-momentum cons. check
18019          IF (LEMCCK) THEN
18020             CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
18021             CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
18022      &                                                    IDUM,IDUM)
18023             CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
18024      &                                                    IDUM,IDUM)
18025          ENDIF
18026 *   get Lorentz-parameter of 3 particle initial state
18027          DO 6 K=1,4
18028             PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
18029     6    CONTINUE
18030          P3P  = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
18031          AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
18032          DO 7 K=1,4
18033             BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
18034     7    CONTINUE
18035 *   2-particle decay of the 3-particle compound system
18036          CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
18037      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
18038      &               AAM(IDFSP(1)),AAM(IDFSP(2)))
18039          DO 8 I=1,2
18040             SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
18041             PX  = PCMF(I)*COFF(I)*SDF
18042             PY  = PCMF(I)*SIFF(I)*SDF
18043             PZ  = PCMF(I)*CODF(I)
18044             CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
18045      &                  ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
18046      &                  PFSP(4,I))
18047             PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
18048 *   check consistency of kinematics
18049             IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
18050                WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
18051  1001          FORMAT(1X,'ABSORP:   warning! inconsistent',
18052      &                ' tree-particle kinematics',/,20X,'id: ',I3,
18053      &                ' AAM = ',E10.4,' MFSP = ',E10.4)
18054             ENDIF
18055 *   dump final state particles for energy-momentum cons. check
18056             IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18057      &                              -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18058     8    CONTINUE
18059          NFSP = 2
18060          IF (LEMCCK) THEN
18061             CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
18062             IF (IREJ1.NE.0) THEN
18063                WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
18064      &                      AM3P
18065                GOTO 9999
18066             ENDIF
18067          ENDIF
18068       ELSE
18069          IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
18070  1000    FORMAT(1X,'ABSORP:   warning! absorption for particle ',I3,
18071      &          ' impossible',/,20X,'too few spectators (',I2,')')
18072          NSPE = 0
18073       ENDIF
18074
18075       RETURN
18076
18077  9999 CONTINUE
18078       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
18079       IREJ = 1
18080       RETURN
18081       END
18082
18083 *$ CREATE DT_HADRIN.FOR
18084 *COPY DT_HADRIN
18085 *
18086 *===hadrin=============================================================*
18087 *
18088       SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
18089
18090 ************************************************************************
18091 * Interface to the HADRIN-routines for inelastic and elastic           *
18092 * scattering.                                                          *
18093 *      IDPR,PPR(5)   identity, momentum of projectile                  *
18094 *      IDTA,PTA(5)   identity, momentum of target                      *
18095 *      MODE  = 1     inelastic interaction                             *
18096 *            = 2     elastic   interaction                             *
18097 * Revised version of the original FHAD.                                *
18098 * This version dated 27.10.95 is written by S. Roesler                 *
18099 ************************************************************************
18100
18101       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18102       SAVE
18103
18104       PARAMETER ( LINP = 10 ,
18105      &            LOUT = 6 ,
18106      &            LDAT = 9 )
18107
18108       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
18109      &           TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
18110
18111       LOGICAL LCORR,LMSSG
18112
18113 * flags for input different options
18114       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18115       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18116      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18117
18118 * final state after inc step
18119       PARAMETER (MAXFSP=10)
18120       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18121
18122 * particle properties (BAMJET index convention)
18123       CHARACTER*8  ANAME
18124       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18125      &                IICH(210),IIBAR(210),K1(210),K2(210)
18126 * output-common for DHADRI/ELHAIN
18127
18128 * final state from HADRIN interaction
18129       PARAMETER (MAXFIN=10)
18130       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
18131      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
18132
18133       DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
18134      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
18135
18136       DATA LMSSG /.TRUE./
18137
18138       IREJ  = 0
18139       NFSP  = 0
18140       KCORR = 0
18141       IMCORR(1) = 0
18142       IMCORR(2) = 0
18143       LCORR = .FALSE.
18144
18145 *   dump initial particles for energy-momentum cons. check
18146       IF (LEMCCK) THEN
18147          CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
18148          CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
18149       ENDIF
18150
18151       AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
18152       AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
18153       IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
18154      &    (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
18155      &    (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
18156          IF (LMSSG.AND.(IOULEV(3).GT.0))
18157      &   WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
18158  1000    FORMAT(1X,'HADRIN:   warning! inconsistent projectile/target',
18159      &          ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
18160      &          E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
18161          LMSSG = .FALSE.
18162          LCORR = .TRUE.
18163       ENDIF
18164
18165 * convert initial state particles into particles which can be
18166 * handled by HADRIN
18167       IDHPR = IDPR
18168       IDHTA = IDTA
18169       IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
18170          IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
18171          DO 1 K=1,4
18172             P1IN(K) = PPR(K)
18173             P2IN(K) = PTA(K)
18174     1    CONTINUE
18175          XM1 = AAM(IDHPR)
18176          XM2 = AAM(IDHTA)
18177          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18178          IF (IREJ1.GT.0) THEN
18179             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
18180             GOTO 9999
18181          ENDIF
18182          DO 2 K=1,4
18183             PPR(K) = P1OUT(K)
18184             PTA(K) = P2OUT(K)
18185     2    CONTINUE
18186          PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
18187          PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
18188       ENDIF
18189
18190 * Lorentz-parameter for trafo into rest-system of target
18191       DO 3 K=1,4
18192          BGTA(K) = PTA(K)/PTA(5)
18193     3 CONTINUE
18194 * transformation of projectile into rest-system of target
18195       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
18196      &            PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
18197      &            PPR1(4))
18198
18199 * direction cosines of projectile in target rest system
18200       CX = PPR1(1)/PPRTO1
18201       CY = PPR1(2)/PPRTO1
18202       CZ = PPR1(3)/PPRTO1
18203
18204 * sample inelastic interaction
18205       IF (MODE.EQ.1) THEN
18206          CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
18207          IF (IRH.EQ.1) GOTO 9998
18208 * sample elastic interaction
18209       ELSEIF (MODE.EQ.2) THEN
18210          CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
18211          IF (IREJ1.NE.0) THEN
18212             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
18213             GOTO 9999
18214          ENDIF
18215          IF (IRH.EQ.1) GOTO 9998
18216       ELSE
18217          WRITE(LOUT,1001) MODE,INTHAD
18218  1001    FORMAT(1X,'HADRIN:   warning! inconsistent interaction mode',
18219      &          I4,' (INTHAD =',I4,')')
18220          GOTO 9999
18221       ENDIF
18222
18223 * transform final state particles back into Lab.
18224       DO 4 I=1,IRH
18225          NFSP = NFSP+1
18226          PX   = CXRH(I)*PLRH(I)
18227          PY   = CYRH(I)*PLRH(I)
18228          PZ   = CZRH(I)*PLRH(I)
18229          CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
18230      &               PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
18231      &               PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
18232          IDFSP(NFSP) = ITRH(I)
18233          AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
18234      &                                            PFSP(3,NFSP)**2
18235          IF (AMFSP2.LT.-TINY3) THEN
18236             WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
18237      &                       PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
18238  1002       FORMAT(1X,'HADRIN:   warning! final state particle (id = ',
18239      &             I2,') with negative mass^2',/,1X,5E12.4)
18240             GOTO 9999
18241          ELSE
18242             PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
18243             IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
18244                WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
18245      &                          PFSP(5,NFSP)
18246  1003          FORMAT(1X,'HADRIN:   warning! final state particle',
18247      &                ' (id = ',I2,') with inconsistent mass',/,1X,
18248      &                2E12.4)
18249                KCORR         = KCORR+1
18250                IF (KCORR.GT.2) GOTO 9999
18251                IMCORR(KCORR) = NFSP
18252             ENDIF
18253          ENDIF
18254 *   dump final state particles for energy-momentum cons. check
18255          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18256      &                           -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18257     4 CONTINUE
18258
18259 * transform momenta on mass shell in case of inconsistencies in
18260 * HADRIN
18261       IF (KCORR.GT.0) THEN
18262          IF (KCORR.EQ.2) THEN
18263             I1 = IMCORR(1)
18264             I2 = IMCORR(2)
18265          ELSE
18266             IF (IMCORR(1).EQ.1) THEN
18267                I1 = 1
18268                I2 = 2
18269             ELSE
18270                I1 = 1
18271                I2 = IMCORR(1)
18272             ENDIF
18273          ENDIF
18274          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
18275      &                           PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
18276          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
18277      &                           PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
18278          DO 5 K=1,4
18279             P1IN(K) = PFSP(K,I1)
18280             P2IN(K) = PFSP(K,I2)
18281     5    CONTINUE
18282          XM1 = AAM(IDFSP(I1))
18283          XM2 = AAM(IDFSP(I2))
18284          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18285          IF (IREJ1.GT.0) THEN
18286             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
18287 C           GOTO 9999
18288          ENDIF
18289          DO 6 K=1,4
18290             PFSP(K,I1) = P1OUT(K)
18291             PFSP(K,I2) = P2OUT(K)
18292     6    CONTINUE
18293          PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
18294      &                    -PFSP(2,I1)**2-PFSP(3,I1)**2)
18295          PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
18296      &                    -PFSP(2,I2)**2-PFSP(3,I2)**2)
18297 *   dump final state particles for energy-momentum cons. check
18298          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
18299      &                           -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
18300          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
18301      &                           -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
18302       ENDIF
18303
18304 * check energy-momentum conservation
18305       IF (LEMCCK) THEN
18306          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
18307          IF (IREJ1.NE.0) GOTO 9999
18308       ENDIF
18309
18310       RETURN
18311
18312  9998 CONTINUE
18313       IREJ = 2
18314       RETURN
18315
18316  9999 CONTINUE
18317       IREJ = 1
18318       RETURN
18319       END
18320
18321 *$ CREATE DT_HADCOL.FOR
18322 *COPY DT_HADCOL
18323 *
18324 *===hadcol=============================================================*
18325 *
18326       SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
18327
18328 ************************************************************************
18329 * Interface to the HADRIN-routines for inelastic and elastic           *
18330 * scattering. This subroutine samples hadron-nucleus interactions      *
18331 * below DPM-threshold.                                                 *
18332 *      IDPROJ        BAMJET-index of projectile hadron                 *
18333 *      PPN           projectile momentum in target rest frame          *
18334 *      IDXTAR        DTEVT1-index of target nucleon undergoing         *
18335 *                    interaction with projectile hadron                *
18336 * This subroutine replaces HADHAD.                                     *
18337 * This version dated 5.5.95 is written by S. Roesler                   *
18338 ************************************************************************
18339
18340       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18341       SAVE
18342
18343       PARAMETER ( LINP = 10 ,
18344      &            LOUT = 6 ,
18345      &            LDAT = 9 )
18346
18347       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
18348
18349       LOGICAL LSTART
18350
18351 * event history
18352
18353       PARAMETER (NMXHKK=200000)
18354
18355       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18356      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18357      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18358
18359 * extended event history
18360       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18361      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18362      &                IHIST(2,NMXHKK)
18363
18364 * nuclear potential
18365       LOGICAL LFERMI
18366       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18367      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18368      &                ETACOU(2),ICOUL,LFERMI
18369
18370 * interface HADRIN-DPM
18371       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
18372
18373 * parameter for intranuclear cascade
18374       LOGICAL LPAULI
18375       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
18376
18377 * final state after inc step
18378       PARAMETER (MAXFSP=10)
18379       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18380
18381 * particle properties (BAMJET index convention)
18382       CHARACTER*8  ANAME
18383       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18384      &                IICH(210),IIBAR(210),K1(210),K2(210)
18385
18386       DIMENSION PPROJ(5),PNUC(5)
18387
18388       DATA LSTART /.TRUE./
18389
18390       IREJ   = 0
18391
18392       NPOINT(1) = NHKK+1
18393
18394       TAUSAV = TAUFOR
18395 **sr 6/9/01 commented
18396 C     TAUFOR = TAUFOR/2.0D0
18397 **
18398       IF (LSTART) THEN
18399          WRITE(LOUT,1000)
18400  1000    FORMAT(/,1X,'HADCOL:  Scattering handled by HADRIN')
18401          WRITE(LOUT,1001) TAUFOR
18402  1001    FORMAT(/,1X,'HADCOL:  Formation zone parameter set to ',
18403      &          F5.1,' fm/c')
18404          LSTART = .FALSE.
18405       ENDIF
18406
18407       IDNUC  = IDBAM(IDXTAR)
18408       IDNUC1 = IDT_MCHAD(IDNUC)
18409       IDPRO1 = IDT_MCHAD(IDPROJ)
18410
18411       IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
18412          IPROC = INTHAD
18413       ELSE
18414 **
18415 C        CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
18416 C        CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
18417          DUMZER = ZERO
18418          CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
18419          SIGIN = SIGTOT-SIGEL
18420 C        SIGTOT = SIGIN+SIGEL
18421 **
18422          IPROC  = 1
18423          IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
18424       ENDIF
18425
18426       PPROJ(1) = ZERO
18427       PPROJ(2) = ZERO
18428       PPROJ(3) = PPN
18429       PPROJ(5) = AAM(IDPROJ)
18430       PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
18431       DO 1 K=1,5
18432          PNUC(K)  = PHKK(K,IDXTAR)
18433     1 CONTINUE
18434
18435       ILOOP = 0
18436     2 CONTINUE
18437       ILOOP = ILOOP+1
18438       IF (ILOOP.GT.100) GOTO 9999
18439
18440       CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
18441       IF (IREJ1.EQ.1) GOTO 9999
18442
18443       IF (IREJ1.GT.1) THEN
18444 * no interaction possible
18445 *   require Pauli blocking
18446          IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
18447          IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
18448          IF ((IIBAR(IDPROJ).NE.1).AND.
18449      &       (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5)))              GOTO 2
18450 *   store incoming particle as final state particle
18451          CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
18452          CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
18453          NPOINT(4) = NHKK
18454       ELSE
18455 * require Pauli blocking for final state nucleons
18456          DO 4 I=1,NFSP
18457             IF ((IDFSP(I).EQ.1).AND.
18458      &          (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I))))       GOTO 2
18459             IF ((IDFSP(I).EQ.8).AND.
18460      &          (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I))))       GOTO 2
18461             IF ((IIBAR(IDFSP(I)).NE.1).AND.
18462      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
18463     4    CONTINUE
18464 * store final state particles
18465          DO 5 I=1,NFSP
18466             IST = 1
18467             IF ((IIBAR(IDFSP(I)).EQ.1).AND.
18468      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
18469             IDHAD = IDT_IPDGHA(IDFSP(I))
18470             CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
18471             CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
18472      &                                        PCMS,ECMS,0,0,0)
18473             IF (I.EQ.1) NPOINT(4) = NHKK
18474             VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
18475             VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
18476             VHKK(3,NHKK) = VHKK(3,IDXTAR)
18477             VHKK(4,NHKK) = VHKK(4,IDXTAR)
18478             WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
18479             WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
18480             WHKK(3,NHKK) = WHKK(3,1)
18481             WHKK(4,NHKK) = WHKK(4,1)
18482     5    CONTINUE
18483       ENDIF
18484       TAUFOR = TAUSAV
18485       RETURN
18486
18487  9999 CONTINUE
18488       IREJ = 1
18489       TAUFOR = TAUSAV
18490       RETURN
18491       END
18492 *$ CREATE DT_GETEMU.FOR
18493 *COPY DT_GETEMU
18494 *
18495 *===getemu=============================================================*
18496 *
18497       SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
18498
18499 ************************************************************************
18500 * Sampling of emulsion component to be considered as target-nucleus.   *
18501 * This version dated 6.5.95   is written by S. Roesler.                *
18502 ************************************************************************
18503
18504       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18505       SAVE
18506
18507       PARAMETER ( LINP = 10 ,
18508      &            LOUT = 6 ,
18509      &            LDAT = 9 )
18510
18511       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18512
18513       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
18514
18515 * emulsion treatment
18516       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
18517      &                NCOMPO,IEMUL
18518
18519 * Glauber formalism: flags and parameters for statistics
18520       LOGICAL LPROD
18521       CHARACTER*8 CGLB
18522       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
18523
18524       IF (MODE.EQ.0) THEN
18525          SUMFRA = ZERO
18526          RR = DT_RNDM(SUMFRA)
18527          IT  = 0
18528          ITZ = 0
18529          DO 1 ICOMP=1,NCOMPO
18530             SUMFRA = SUMFRA+EMUFRA(ICOMP)
18531             IF (SUMFRA.GT.RR) THEN
18532                IT    = IEMUMA(ICOMP)
18533                ITZ   = IEMUCH(ICOMP)
18534                KKMAT = ICOMP
18535                GOTO 2
18536             ENDIF
18537     1    CONTINUE
18538     2    CONTINUE
18539          IF (IT.LE.0) THEN
18540             WRITE(LOUT,'(1X,A,E12.3)')
18541      &       'Warning!  norm. failure within emulsion fractions',
18542      &       SUMFRA
18543             STOP
18544          ENDIF
18545       ELSEIF (MODE.EQ.1) THEN
18546          NDIFF = 10000
18547          DO 3 I=1,NCOMPO
18548             IDIFF = ABS(IT-IEMUMA(I))
18549             IF (IDIFF.LT.NDIFF) THEN
18550                KKMAT = I
18551                NDIFF = IDIFF
18552             ENDIF
18553     3    CONTINUE
18554       ELSE
18555          STOP 'DT_GETEMU'
18556       ENDIF
18557
18558 * bypass for variable projectile/target/energy runs: the correct
18559 * Glauber data will be always loaded on kkmat=1
18560       IF (IOGLB.EQ.100) THEN
18561          KKMAT = 1
18562       ENDIF
18563
18564       RETURN
18565       END
18566
18567 *$ CREATE DT_NCLPOT.FOR
18568 *COPY DT_NCLPOT
18569 *
18570 *===nclpot=============================================================*
18571 *
18572       SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
18573
18574 ************************************************************************
18575 * Calculation of Coulomb and nuclear potential for a given configurat. *
18576 *               IPZ, IP       charge/mass number of proj.              *
18577 *               ITZ, IT       charge/mass number of targ.              *
18578 *               AFERP,AFERT   factors modifying proj./target pot.      *
18579 *                             if =0, FERMOD is used                    *
18580 *               MODE = 0      calculation of binding energy            *
18581 *                    = 1      pre-calculated binding energy is used    *
18582 * This version dated 16.11.95  is written by S. Roesler.               *
18583 *                                                                      *
18584 * Last change 28.12.2006 by S. Roesler.                                *
18585 ************************************************************************
18586
18587       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18588       SAVE
18589
18590       PARAMETER ( LINP = 10 ,
18591      &            LOUT = 6 ,
18592      &            LDAT = 9 )
18593
18594       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18595      &           TINY10=1.0D-10)
18596
18597       LOGICAL LSTART
18598
18599 * particle properties (BAMJET index convention)
18600       CHARACTER*8  ANAME
18601       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18602      &                IICH(210),IIBAR(210),K1(210),K2(210)
18603
18604 * nuclear potential
18605       LOGICAL LFERMI
18606       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18607      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18608      &                ETACOU(2),ICOUL,LFERMI
18609
18610       DIMENSION IDXPOT(14)
18611 *                   ap   an  lam  alam sig- sig+ sig0 tet0 tet- asig-
18612       DATA IDXPOT /   2,   9,  17,  18,  20,  21,  22,  97,  98,  99,
18613 *                 asig0 asig+ atet0 atet+
18614      &              100, 101, 102, 103/
18615
18616       DATA AN     /0.4D0/
18617       DATA LSTART /.TRUE./
18618
18619       IF (MODE.EQ.0) THEN
18620          EBINDP(1) = ZERO
18621          EBINDN(1) = ZERO
18622          EBINDP(2) = ZERO
18623          EBINDN(2) = ZERO
18624       ENDIF
18625       AIP  = DBLE(IP)
18626       AIPZ = DBLE(IPZ)
18627       AIT  = DBLE(IT)
18628       AITZ = DBLE(ITZ)
18629
18630       FERMIP = AFERP
18631       IF (AFERP.LE.ZERO) FERMIP = FERMOD
18632       FERMIT = AFERT
18633       IF (AFERT.LE.ZERO) FERMIT = FERMOD
18634
18635 * Fermi momenta and binding energy for projectile
18636       IF ((IP.GT.1).AND.LFERMI) THEN
18637          IF (MODE.EQ.0) THEN
18638 C           EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
18639 C           EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
18640             BIP  = AIP -ONE
18641             BIPZ = AIPZ-ONE
18642
18643 C           EBINDP(1) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIP,BIPZ)
18644 C    &                                         -ENERGY(AIP,AIPZ))
18645             EBINDP(1) = 1.0D-3*(EXMSAZ(ONE,ONE ,.TRUE.,IZDUM)
18646      &                         +EXMSAZ(BIP,BIPZ,.TRUE.,IZDUM)
18647      &                         -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18648
18649             IF (AIP.LE.AIPZ) THEN
18650                EBINDN(1) = EBINDP(1)
18651                WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
18652             ELSE
18653
18654 C              EBINDN(1) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIP,AIPZ)
18655 C    &                                             -ENERGY(AIP,AIPZ))
18656                EBINDN(1) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18657      &                            +EXMSAZ(BIP,AIPZ,.TRUE.,IZDUM)
18658      &                            -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18659
18660             ENDIF
18661          ENDIF
18662          PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
18663          PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
18664       ELSE
18665          PFERMP(1) = ZERO
18666          PFERMN(1) = ZERO
18667       ENDIF
18668 * effective nuclear potential for projectile
18669 C     EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
18670 C     EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
18671       EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
18672       EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
18673
18674 * Fermi momenta and binding energy for target
18675       IF ((IT.GT.1).AND.LFERMI) THEN
18676          IF (MODE.EQ.0) THEN
18677 C           EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
18678 C           EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
18679             BIT  = AIT -ONE
18680             BITZ = AITZ-ONE
18681
18682 C           EBINDP(2) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIT,BITZ)
18683 C    &                                         -ENERGY(AIT,AITZ))
18684             EBINDP(2) = 1.0D-3*(EXMSAZ(ONE,ONE, .TRUE.,IZDUM)
18685      &                         +EXMSAZ(BIT,BITZ,.TRUE.,IZDUM)
18686      &                         -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18687
18688             IF (AIT.LE.AITZ) THEN
18689                EBINDN(2) = EBINDP(2)
18690                WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
18691             ELSE
18692
18693 C              EBINDN(2) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIT,AITZ)
18694 C    &                                             -ENERGY(AIT,AITZ))
18695                EBINDN(2) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18696      &                            +EXMSAZ(BIT,AITZ,.TRUE.,IZDUM)
18697      &                            -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18698
18699             ENDIF
18700          ENDIF
18701          PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
18702          PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
18703       ELSE
18704          PFERMP(2) = ZERO
18705          PFERMN(2) = ZERO
18706       ENDIF
18707 * effective nuclear potential for target
18708 C     EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
18709 C     EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
18710       EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
18711       EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
18712
18713       DO 2 I=1,14
18714          EPOT(1,IDXPOT(I)) = EPOT(1,8)
18715          EPOT(2,IDXPOT(I)) = EPOT(2,8)
18716     2 CONTINUE
18717
18718 * Coulomb energy
18719       ETACOU(1) = ZERO
18720       ETACOU(2) = ZERO
18721       IF (ICOUL.EQ.1) THEN
18722          IF (IP.GT.1)
18723      &   ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
18724          IF (IT.GT.1)
18725      &   ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
18726       ENDIF
18727
18728       IF (LSTART) THEN
18729          WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
18730      &                    EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
18731      &                    EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
18732      &                    FERMOD,ETACOU
18733  1000    FORMAT(/,/,1X,'NCLPOT:    quantities for inclusion of nuclear'
18734      &           ,' effects',/,12X,'---------------------------',
18735      &           '----------------',/,/,38X,'projectile',
18736      &           '      target',/,/,1X,'Mass number / charge',
18737      &           17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy  -',
18738      &           ' proton   (GeV) ',2E14.4,/,17X,'- neutron  (GeV)'
18739      &          ,1X,2E14.4,/,1X,'Fermi-potential - proton   (GeV)',
18740      &           1X,2E14.4,/,17X,'- neutron  (GeV) ',2E14.4,/,/,
18741      &           1X,'Scale factor for Fermi-momentum    ',F4.2,/,
18742      &           /,1X,'Coulomb-energy ',2(E14.4,' GeV  '),/,/)
18743          LSTART = .FALSE.
18744       ENDIF
18745
18746       RETURN
18747       END
18748
18749 *$ CREATE DT_RESNCL.FOR
18750 *COPY DT_RESNCL
18751 *
18752 *===resncl=============================================================*
18753 *
18754       SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
18755
18756 ************************************************************************
18757 * Treatment of residual nuclei and nuclear effects.                    *
18758 *         MODE = 1     initializations                                 *
18759 *              = 2     treatment of final state                        *
18760 * This version dated 16.11.95 is written by S. Roesler.                *
18761 *                                                                      *
18762 * Last change 05.01.2007 by S. Roesler.                                *
18763 ************************************************************************
18764
18765       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18766       SAVE
18767
18768       PARAMETER ( LINP = 10 ,
18769      &            LOUT = 6 ,
18770      &            LDAT = 9 )
18771
18772       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
18773      &           TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
18774      &           ONETHI=ONE/THREE)
18775       PARAMETER (AMUAMU = 0.93149432D0,
18776      &           FM2MM  = 1.0D-12,
18777      &           RNUCLE = 1.12D0)
18778       PARAMETER ( EMVGEV = 1.0                D-03 )
18779       PARAMETER ( AMUGEV = 0.93149432         D+00 )
18780       PARAMETER ( AMPRTN = 0.93827231         D+00 )
18781       PARAMETER ( AMNTRN = 0.93956563         D+00 )
18782       PARAMETER ( AMELCT = 0.51099906         D-03 )
18783       PARAMETER ( HLFHLF = 0.5D+00 )
18784       PARAMETER ( FERTHO = 14.33       D-09 )
18785       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
18786       PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
18787       PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
18788
18789 * event history
18790
18791       PARAMETER (NMXHKK=200000)
18792
18793       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18794      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18795      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18796
18797 * extended event history
18798       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18799      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18800      &                IHIST(2,NMXHKK)
18801
18802 * particle properties (BAMJET index convention)
18803       CHARACTER*8  ANAME
18804       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18805      &                IICH(210),IIBAR(210),K1(210),K2(210)
18806
18807 * flags for input different options
18808       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18809       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18810      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18811
18812 * nuclear potential
18813       LOGICAL LFERMI
18814       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18815      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18816      &                ETACOU(2),ICOUL,LFERMI
18817
18818 * properties of interacting particles
18819       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18820
18821 * properties of photon/lepton projectiles
18822       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
18823
18824 * Lorentz-parameters of the current interaction
18825       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
18826      &                UMO,PPCM,EPROJ,PPROJ
18827
18828 * treatment of residual nuclei: wounded nucleons
18829       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18830
18831 * treatment of residual nuclei: 4-momenta
18832       LOGICAL LRCLPR,LRCLTA
18833       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18834      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18835
18836       DIMENSION PFSP(4),PSEC(4),PSEC0(4)
18837       DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
18838      &          IDXCOR(15000),IDXOTH(NMXHKK)
18839
18840       GOTO (1,2) MODE
18841
18842 *------- initializations
18843     1 CONTINUE
18844
18845 * initialize arrays for residual nuclei
18846       DO 10 K=1,5
18847          IF (K.LE.4) THEN
18848             PFSP(K)     = ZERO
18849          ENDIF
18850          PINIPR(K) = ZERO
18851          PINITA(K) = ZERO
18852          PRCLPR(K) = ZERO
18853          PRCLTA(K) = ZERO
18854          TRCLPR(K) = ZERO
18855          TRCLTA(K) = ZERO
18856    10 CONTINUE
18857       SCPOT = ONE
18858       NLOOP = 0
18859
18860 * correction of projectile 4-momentum for effective target pot.
18861 * and Coulomb-energy (in case of hadron-nucleus interaction only)
18862 *      IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18863 *         EPNI = EPN
18864 *   Coulomb-energy:
18865 *     positively charged hadron - check energy for Coloumb pot.
18866 *         IF (IICH(IJPROJ).EQ.1) THEN
18867 *            THRESH = ETACOU(2)+AAM(IJPROJ)
18868 *            IF (EPNI.LE.THRESH) THEN
18869 *               WRITE(LOUT,1000)
18870 * 1000          FORMAT(/,1X,'KKINC:  WARNING!  projectile energy',
18871 *     &                ' below Coulomb threshold - event rejected',/)
18872 *               ISTHKK(1) = 1
18873 *               RETURN
18874 *            ENDIF
18875 *     negatively charged hadron - increase energy by Coulomb energy
18876 *         ELSEIF (IICH(IJPROJ).EQ.-1) THEN
18877 *            EPNI = EPNI+ETACOU(2)
18878 *         ENDIF
18879 *         IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
18880 *   Effective target potential
18881 *sr 6.6. binding energy only (to avoid negative exc. energies)
18882 C           EPNI = EPNI+EPOT(2,IJPROJ)
18883 *            EBIPOT = EBINDP(2)
18884 *            IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
18885 *     &         EBIPOT = EBINDN(2)
18886 *            EPNI = EPNI+ABS(EBIPOT)
18887 * re-initialization of DTLTRA
18888 *            DUM1 = ZERO
18889 *            DUM2 = ZERO
18890 *            CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
18891 *         ENDIF
18892 *      ENDIF
18893
18894 * projectile in n-n cms
18895       IF ((IP.LE.1).AND.(IT.GT.1)) THEN
18896          PMASS1 = AAM(IJPROJ)
18897 C* VDM assumption
18898 C         IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
18899          IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
18900          PMASS2 = AAM(1)
18901          PM1 = SIGN(PMASS1**2,PMASS1)
18902          PM2 = SIGN(PMASS2**2,PMASS2)
18903          PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
18904          PINIPR(5) = PMASS1
18905          IF (PMASS1.GT.ZERO) THEN
18906             PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
18907      &                      *(PINIPR(4)+PINIPR(5)))
18908          ELSE
18909             PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
18910          ENDIF
18911          AIT  = DBLE(IT)
18912          AITZ = DBLE(ITZ)
18913
18914 C        PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18915          PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18916
18917          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18918       ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
18919          PMASS1 = AAM(1)
18920          PMASS2 = AAM(IJTARG)
18921          PM1 = SIGN(PMASS1**2,PMASS1)
18922          PM2 = SIGN(PMASS2**2,PMASS2)
18923          PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
18924          PINITA(5) = PMASS2
18925          PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18926      &                    *(PINITA(4)+PINITA(5)))
18927          AIP  = DBLE(IP)
18928          AIPZ = DBLE(IPZ)
18929
18930 C        PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18931          PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18932
18933          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18934       ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18935          AIP  = DBLE(IP)
18936          AIPZ = DBLE(IPZ)
18937
18938 C        PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18939          PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18940
18941          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18942          AIT  = DBLE(IT)
18943          AITZ = DBLE(ITZ)
18944
18945 C        PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18946          PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18947
18948          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18949       ENDIF
18950
18951       RETURN
18952
18953 *------- treatment of final state
18954     2 CONTINUE
18955
18956       NLOOP = NLOOP+1
18957       IF (NLOOP.GT.1) SCPOT = 0.10D0
18958 C     WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18959
18960       JPW  = NPW
18961       JPCW = NPCW
18962       JTW  = NTW
18963       JTCW = NTCW
18964       DO 40 K=1,4
18965          PFSP(K)   = ZERO
18966    40 CONTINUE
18967
18968       NOB = 0
18969       NOM = 0
18970       DO 900 I=NPOINT(4),NHKK
18971          IDXOTH(I) = -1
18972          IF (ISTHKK(I).EQ.1) THEN
18973             IF (IDBAM(I).EQ.7) GOTO 900
18974             IPOT = 0
18975             IOTHER = 0
18976 * particle moving into forward direction
18977             IF (PHKK(3,I).GE.ZERO) THEN
18978 *   most likely to be effected by projectile potential
18979                IPOT = 1
18980 *     there is no projectile nucleus, try target
18981                IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18982                   IPOT   = 2
18983                   IF (IP.GT.1) IOTHER = 1
18984 *       there is no target nucleus --> skip
18985                   IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18986                ENDIF
18987 * particle moving into backward direction
18988             ELSE
18989 *   most likely to be effected by target potential
18990                IPOT = 2
18991 *     there is no target nucleus, try projectile
18992                IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18993                   IPOT   = 1
18994                   IF (IT.GT.1) IOTHER = 1
18995 *       there is no projectile nucleus --> skip
18996                   IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18997                ENDIF
18998             ENDIF
18999             IFLG = -IPOT
19000 * nobam=3: particle is in overlap-region or neither inside proj. nor target
19001 *      =1: particle is not in overlap-region AND is inside target (2)
19002 *      =2: particle is not in overlap-region AND is inside projectile (1)
19003 * flag particles which are inside the nucleus ipot but not in its
19004 * overlap region
19005             IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
19006             IF (IDBAM(I).NE.0) THEN
19007 * baryons: keep all nucleons and all others where flag is set
19008                IF (IIBAR(IDBAM(I)).NE.0) THEN
19009                   IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
19010      &                                                              THEN
19011                      NOB = NOB+1
19012                      PMOMB(NOB) = PHKK(3,I)
19013                      IDXB(NOB)  = SIGN(10000000*IABS(IFLG)
19014      &                           +1000000*IOTHER+I,IFLG)
19015                   ENDIF
19016 * mesons: keep only those mesons where flag is set
19017                ELSE
19018                   IF (IFLG.GT.0) THEN
19019                      NOM = NOM+1
19020                      PMOMM(NOM) = PHKK(3,I)
19021                      IDXM(NOM)  = 10000000*IFLG+1000000*IOTHER+I
19022                   ENDIF
19023                ENDIF
19024             ENDIF
19025          ENDIF
19026   900 CONTINUE
19027 *
19028 * sort particles in the arrays according to increasing long. momentum
19029       CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
19030       CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
19031 *
19032 * shuffle indices into one and the same array according to the later
19033 * sequence of correction
19034       NCOR = 0
19035       IF (IT.GT.1) THEN
19036          DO 910 I=1,NOB
19037             IF (PMOMB(I).GT.ZERO) GOTO 911
19038             NCOR = NCOR+1
19039             IDXCOR(NCOR) = IDXB(I)
19040   910    CONTINUE
19041   911    CONTINUE
19042          IF (IP.GT.1) THEN
19043             DO 912 J=1,NOB
19044                I = NOB+1-J
19045                IF (PMOMB(I).LT.ZERO) GOTO 913
19046                NCOR = NCOR+1
19047                IDXCOR(NCOR) = IDXB(I)
19048   912       CONTINUE
19049   913       CONTINUE
19050          ELSE
19051             DO 914 I=1,NOB
19052                IF (PMOMB(I).GT.ZERO) THEN
19053                   NCOR = NCOR+1
19054                   IDXCOR(NCOR) = IDXB(I)
19055                ENDIF
19056   914       CONTINUE
19057          ENDIF
19058       ELSE
19059          DO 915 J=1,NOB
19060             I = NOB+1-J
19061             NCOR = NCOR+1
19062             IDXCOR(NCOR) = IDXB(I)
19063   915    CONTINUE
19064       ENDIF
19065       DO 925 I=1,NOM
19066          IF (PMOMM(I).GT.ZERO) GOTO 926
19067          NCOR = NCOR+1
19068          IDXCOR(NCOR) = IDXM(I)
19069   925 CONTINUE
19070   926 CONTINUE
19071       DO 927 J=1,NOM
19072          I = NOM+1-J
19073          IF (PMOMM(I).LT.ZERO) GOTO 928
19074          NCOR = NCOR+1
19075          IDXCOR(NCOR) = IDXM(I)
19076   927 CONTINUE
19077   928 CONTINUE
19078 *
19079 C      IF (NEVHKK.EQ.484) THEN
19080 C         WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
19081 C 9000    FORMAT(1X,'wounded nucleons (proj.-p,n  targ.-p,n)',/,4I10)
19082 C         WRITE(LOUT,9001) NOB,NOM,NCOR
19083 C 9001    FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
19084 C         WRITE(LOUT,'(/,A)') ' baryons '
19085 C         DO 950 I=1,NOB
19086 CC           J     = IABS(IDXB(I))
19087 CC           INDEX = J-IABS(J/10000000)*10000000
19088 C            IPOT   = IABS(IDXB(I))/10000000
19089 C            IOTHER = IABS(IDXB(I))/1000000-IPOT*10
19090 C            INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
19091 C            WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
19092 C  950    CONTINUE
19093 C         WRITE(LOUT,'(/,A)') ' mesons '
19094 C         DO 951 I=1,NOM
19095 CC           INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
19096 C            IPOT   = IABS(IDXM(I))/10000000
19097 C            IOTHER = IABS(IDXM(I))/1000000-IPOT*10
19098 C            INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
19099 C            WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
19100 C  951    CONTINUE
19101 C 9002    FORMAT(1X,4I14,E14.5)
19102 C         WRITE(LOUT,'(/,A)') ' all '
19103 C         DO 952 I=1,NCOR
19104 CC           J     = IABS(IDXCOR(I))
19105 CC           INDEX = J-IABS(J/10000000)*10000000
19106 CC            IPOT   = IABS(IDXCOR(I))/10000000
19107 C            IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
19108 C            INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
19109 C            WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
19110 C  952    CONTINUE
19111 C 9003    FORMAT(1X,4I14)
19112 C      ENDIF
19113 *
19114       DO 20 ICOR=1,NCOR
19115          IPOT   = IABS(IDXCOR(ICOR))/10000000
19116          IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
19117          I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
19118          IDXOTH(I) = 1
19119
19120          IDSEC  = IDBAM(I)
19121
19122 * reduction of particle momentum by corresponding nuclear potential
19123 * (this applies only if Fermi-momenta are requested)
19124
19125          IF (LFERMI) THEN
19126
19127 *   Lorentz-transformation into the rest system of the selected nucleus
19128             IMODE = -IPOT-1
19129             CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19130      &                  PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
19131             PSECO  = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
19132             AMSEC  = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
19133             JPMOD  = 0
19134
19135             CHKLEV = TINY3
19136             IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
19137             IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
19138             IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
19139                IF (IOULEV(3).GT.0)
19140      &            WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
19141  2000          FORMAT(1X,'RESNCL: inconsistent mass of particle',
19142      &                ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
19143      &                I4,'   AMSEC: ',E12.3,'  AAM(IDSEC): ',E12.3,/)
19144                GOTO 23
19145             ENDIF
19146
19147             DO 21 K=1,4
19148                PSEC0(K) = PSEC(K)
19149    21       CONTINUE
19150
19151 *   the correction for nuclear potential effects is applied to as many
19152 *   p/n as many nucleons were wounded; the momenta of other final state
19153 *   particles are corrected only if they materialize inside the corresp.
19154 *   nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
19155 *   = 3 part. outside proj. and targ., >=10 in overlapping region)
19156             IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
19157                IF (IPOT.EQ.1) THEN
19158                   IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
19159 *      this is most likely a wounded nucleon
19160 **test
19161 C                    RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
19162 C    &                           +(VHKK(2,IPW(JPW))/FM2MM)**2
19163 C    &                           +(VHKK(3,IPW(JPW))/FM2MM)**2)
19164 C                    RAD   = RNUCLE*DBLE(IP)**ONETHI
19165 C                    FDEN  = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
19166 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19167 **
19168                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19169                      JPW = JPW-1
19170                      JPMOD = 1
19171                   ELSE
19172 *      correct only if part. was materialized inside nucleus
19173 *      and if it is ouside the overlapping region
19174                      IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
19175                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19176                         JPMOD = 1
19177                      ENDIF
19178                   ENDIF
19179                ELSEIF (IPOT.EQ.2) THEN
19180                   IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
19181 *      this is most likely a wounded nucleon
19182 **test
19183 C                    RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
19184 C    &                           +(VHKK(2,ITW(JTW))/FM2MM)**2
19185 C    &                           +(VHKK(3,ITW(JTW))/FM2MM)**2)
19186 C                    RAD   = RNUCLE*DBLE(IT)**ONETHI
19187 C                    FDEN  = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
19188 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19189 **
19190                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19191                      JTW = JTW-1
19192                      JPMOD = 1
19193                   ELSE
19194 *      correct only if part. was materialized inside nucleus
19195                      IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
19196                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19197                         JPMOD = 1
19198                      ENDIF
19199                   ENDIF
19200                ENDIF
19201             ELSE
19202                IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
19203                   PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19204                   JPMOD = 1
19205                ENDIF
19206             ENDIF
19207
19208             IF (NLOOP.EQ.1) THEN
19209 * Coulomb energy correction:
19210 * the treatment of Coulomb potential correction is similar to the
19211 * one for nuclear potential
19212                IF (IDSEC.EQ.1) THEN
19213                   IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
19214                      JPCW = JPCW-1
19215                   ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
19216                      JTCW = JTCW-1
19217                   ELSE
19218                      IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19219                   ENDIF
19220                ELSE
19221                   IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19222                ENDIF
19223                IF (IICH(IDSEC).EQ.1) THEN
19224 *    pos. particles: check if they are able to escape Coulomb potential
19225                   IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
19226                      ISTHKK(I) = 14+IPOT
19227                      IF (ISTHKK(I).EQ.15) THEN
19228                         DO 26 K=1,4
19229                            PHKK(K,I) = PSEC0(K)
19230                            TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19231    26                CONTINUE
19232                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19233                         IF (IDSEC.EQ.1) NPCW = NPCW-1
19234                      ELSEIF (ISTHKK(I).EQ.16) THEN
19235                         DO 27 K=1,4
19236                            PHKK(K,I) = PSEC0(K)
19237                            TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19238    27                   CONTINUE
19239                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19240                         IF (IDSEC.EQ.1) NTCW = NTCW-1
19241                      ENDIF
19242                      GOTO 20
19243                   ENDIF
19244                ELSEIF (IICH(IDSEC).EQ.-1) THEN
19245 *    neg. particles: decrease energy by Coulomb-potential
19246                   PSEC(4) = PSEC(4)-ETACOU(IPOT)
19247                   JPMOD = 1
19248                ENDIF
19249             ENDIF
19250
19251    25       CONTINUE
19252
19253             IF (PSEC(4).LT.AMSEC) THEN
19254                IF (IOULEV(6).GT.0)
19255      &            WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
19256  2001          FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
19257      &                ' is not allowed to escape nucleus',/,
19258      &                8X,'id : ',I3,'   reduced energy: ',E15.4,
19259      &                '   mass: ',E12.3)
19260                ISTHKK(I) = 14+IPOT
19261                IF (ISTHKK(I).EQ.15) THEN
19262                   DO 28 K=1,4
19263                      PHKK(K,I) = PSEC0(K)
19264                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19265    28             CONTINUE
19266                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19267                   IF (IDSEC.EQ.1) NPCW = NPCW-1
19268                ELSEIF (ISTHKK(I).EQ.16) THEN
19269                   DO 29 K=1,4
19270                      PHKK(K,I) = PSEC0(K)
19271                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19272    29             CONTINUE
19273                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19274                   IF (IDSEC.EQ.1) NTCW = NTCW-1
19275                ENDIF
19276                GOTO 20
19277             ENDIF
19278
19279             IF (JPMOD.EQ.1) THEN
19280                PSECN  = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
19281 * 4-momentum after correction for nuclear potential
19282                DO 22 K=1,3
19283                   PSEC(K) = PSEC(K)*PSECN/PSECO
19284    22          CONTINUE
19285
19286 * store recoil momentum from particles escaping the nuclear potentials
19287                DO 30 K=1,4
19288                   IF (IPOT.EQ.1) THEN
19289                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
19290                   ELSEIF (IPOT.EQ.2) THEN
19291                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
19292                   ENDIF
19293    30          CONTINUE
19294
19295 * transform momentum back into n-n cms
19296                IMODE = IPOT+1
19297                CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
19298      &                     PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19299      &                     IDSEC,IMODE)
19300             ENDIF
19301
19302          ENDIF
19303
19304    23    CONTINUE
19305          DO 31 K=1,4
19306             PFSP(K) = PFSP(K)+PHKK(K,I)
19307    31    CONTINUE
19308
19309    20 CONTINUE
19310
19311       DO 33 I=NPOINT(4),NHKK
19312          IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
19313             PFSP(1) = PFSP(1)+PHKK(1,I)
19314             PFSP(2) = PFSP(2)+PHKK(2,I)
19315             PFSP(3) = PFSP(3)+PHKK(3,I)
19316             PFSP(4) = PFSP(4)+PHKK(4,I)
19317          ENDIF
19318    33 CONTINUE
19319
19320       DO 34 K=1,5
19321          PRCLPR(K) = TRCLPR(K)
19322          PRCLTA(K) = TRCLTA(K)
19323    34 CONTINUE
19324
19325       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
19326 * hadron-nucleus interactions: get residual momentum from energy-
19327 * momentum conservation
19328          DO 32 K=1,4
19329             PRCLPR(K) = ZERO
19330             PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
19331    32    CONTINUE
19332       ELSE
19333 * nucleus-hadron, nucleus-nucleus: get residual momentum from
19334 * accumulated recoil momenta of particles leaving the spectators
19335 *   transform accumulated recoil momenta of residual nuclei into
19336 *   n-n cms
19337          PZI = PRCLPR(3)
19338          PEI = PRCLPR(4)
19339          CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
19340          PZI = PRCLTA(3)
19341          PEI = PRCLTA(4)
19342          CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
19343 C        IF (IP.GT.1) THEN
19344             PRCLPR(3) = PRCLPR(3)+PINIPR(3)
19345             PRCLPR(4) = PRCLPR(4)+PINIPR(4)
19346 C        ENDIF
19347          IF (IT.GT.1) THEN
19348             PRCLTA(3) = PRCLTA(3)+PINITA(3)
19349             PRCLTA(4) = PRCLTA(4)+PINITA(4)
19350          ENDIF
19351       ENDIF
19352
19353 * check momenta of residual nuclei
19354       IF (LEMCCK) THEN
19355          CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
19356      &               1,IDUM,IDUM)
19357          CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
19358      &               2,IDUM,IDUM)
19359          CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
19360      &               2,IDUM,IDUM)
19361          CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
19362      &               2,IDUM,IDUM)
19363          CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
19364 **sr 19.12. changed to avoid output when used with phojet
19365 C        CHKLEV = TINY3
19366          CHKLEV = TINY1
19367          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
19368 C        IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
19369 C    &      CALL DT_EVTOUT(4)
19370          IF (IREJ1.GT.0) RETURN
19371       ENDIF
19372
19373       RETURN
19374       END
19375
19376 *$ CREATE DT_SCN4BA.FOR
19377 *COPY DT_SCN4BA
19378 *
19379 *===scn4ba=============================================================*
19380 *
19381       SUBROUTINE DT_SCN4BA
19382
19383 ************************************************************************
19384 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot.    *
19385 * This version dated 12.12.95 is written by S. Roesler.                *
19386 ************************************************************************
19387
19388       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19389       SAVE
19390
19391       PARAMETER ( LINP = 10 ,
19392      &            LOUT = 6 ,
19393      &            LDAT = 9 )
19394
19395       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
19396      &           TINY10=1.0D-10)
19397
19398 * event history
19399
19400       PARAMETER (NMXHKK=200000)
19401
19402       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19403      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19404      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19405
19406 * extended event history
19407       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19408      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19409      &                IHIST(2,NMXHKK)
19410
19411 * particle properties (BAMJET index convention)
19412       CHARACTER*8  ANAME
19413       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19414      &                IICH(210),IIBAR(210),K1(210),K2(210)
19415
19416 * properties of interacting particles
19417       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
19418
19419 * nuclear potential
19420       LOGICAL LFERMI
19421       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
19422      &                EBINDP(2),EBINDN(2),EPOT(2,210),
19423      &                ETACOU(2),ICOUL,LFERMI
19424
19425 * treatment of residual nuclei: wounded nucleons
19426       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
19427
19428 * treatment of residual nuclei: 4-momenta
19429       LOGICAL LRCLPR,LRCLTA
19430       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19431      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19432
19433       DIMENSION PLAB(2,5),PCMS(4)
19434
19435       IREJ = 0
19436
19437 * get number of wounded nucleons
19438       NPW    = 0
19439       NPW0   = 0
19440       NPCW   = 0
19441       NPSTCK = 0
19442       NTW    = 0
19443       NTW0   = 0
19444       NTCW   = 0
19445       NTSTCK = 0
19446
19447       ISGLPR = 0
19448       ISGLTA = 0
19449       LRCLPR = .FALSE.
19450       LRCLTA = .FALSE.
19451
19452 C     DO 2 I=1,NHKK
19453       DO 2 I=1,NPOINT(1)
19454 * projectile nucleons wounded in primary interaction and in fzc
19455          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
19456             NPW      = NPW+1
19457             IPW(NPW) = I
19458             NPSTCK   = NPSTCK+1
19459             IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
19460             IF (ISTHKK(I).EQ.11)  NPW0 = NPW0+1
19461 C           IF (IP.GT.1) THEN
19462                DO 5 K=1,4
19463                   TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
19464     5          CONTINUE
19465 C           ENDIF
19466 * target nucleons wounded in primary interaction and in fzc
19467          ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
19468             NTW      = NTW+1
19469             ITW(NTW) = I
19470             NTSTCK   = NTSTCK+1
19471             IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
19472             IF (ISTHKK(I).EQ.12)  NTW0 = NTW0+1
19473             IF (IT.GT.1) THEN
19474                DO 6 K=1,4
19475                   TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
19476     6          CONTINUE
19477             ENDIF
19478          ELSEIF (ISTHKK(I).EQ.13) THEN
19479             ISGLPR = I
19480          ELSEIF (ISTHKK(I).EQ.14) THEN
19481             ISGLTA = I
19482          ENDIF
19483     2 CONTINUE
19484
19485       DO 11 I=NPOINT(4),NHKK
19486 * baryons which are unable to escape the nuclear potential of proj.
19487          IF (ISTHKK(I).EQ.15) THEN
19488             ISGLPR = I
19489             NPSTCK = NPSTCK-1
19490             IF (IIBAR(IDBAM(I)).NE.0) THEN
19491                NPW    = NPW-1
19492                IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
19493             ENDIF
19494             DO 7 K=1,4
19495                TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19496     7       CONTINUE
19497 * baryons which are unable to escape the nuclear potential of targ.
19498          ELSEIF (ISTHKK(I).EQ.16) THEN
19499             ISGLTA = I
19500             NTSTCK = NTSTCK-1
19501             IF (IIBAR(IDBAM(I)).NE.0) THEN
19502                NTW    = NTW-1
19503                IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
19504             ENDIF
19505             DO 8 K=1,4
19506                TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19507     8       CONTINUE
19508          ENDIF
19509    11 CONTINUE
19510
19511 * residual nuclei so far
19512       IRESP = IP-NPSTCK
19513       IREST = IT-NTSTCK
19514
19515 * ckeck for "residual nuclei" consisting of one nucleon only
19516 * treat it as final state particle
19517       IF (IRESP.EQ.1) THEN
19518          ID  = IDBAM(ISGLPR)
19519          IST = ISTHKK(ISGLPR)
19520          CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
19521      &               PHKK(3,ISGLPR),PHKK(4,ISGLPR),
19522      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
19523          IF (IST.EQ.13) THEN
19524             ISTHKK(ISGLPR) = 11
19525          ELSE
19526             ISTHKK(ISGLPR) = 2
19527          ENDIF
19528          CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
19529      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19530      &               IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
19531          NOBAM(NHKK)      = NOBAM(ISGLPR)
19532          JDAHKK(1,ISGLPR) = NHKK
19533          DO 21 K=1,4
19534             TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
19535    21    CONTINUE
19536       ENDIF
19537       IF (IREST.EQ.1) THEN
19538          ID  = IDBAM(ISGLTA)
19539          IST = ISTHKK(ISGLTA)
19540          CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
19541      &               PHKK(3,ISGLTA),PHKK(4,ISGLTA),
19542      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
19543          IF (IST.EQ.14) THEN
19544             ISTHKK(ISGLTA) = 12
19545          ELSE
19546             ISTHKK(ISGLTA) = 2
19547          ENDIF
19548          CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
19549      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19550      &               IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
19551          NOBAM(NHKK)      = NOBAM(ISGLTA)
19552          JDAHKK(1,ISGLTA) = NHKK
19553          DO 22 K=1,4
19554             TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
19555    22    CONTINUE
19556       ENDIF
19557
19558 * get nuclear potential corresp. to the residual nucleus
19559       IPRCL  = IP -NPW
19560       IPZRCL = IPZ-NPCW
19561       ITRCL  = IT -NTW
19562       ITZRCL = ITZ-NTCW
19563       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
19564
19565 * baryons unable to escape the nuclear potential are treated as
19566 * excited nucleons (ISTHKK=15,16)
19567       DO 3 I=NPOINT(4),NHKK
19568          IF (ISTHKK(I).EQ.1) THEN
19569             ID  = IDBAM(I)
19570             IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
19571 *   final state n and p not being outside of both nuclei are considered
19572                NPOTP = 1
19573                NPOTT = 1
19574                IF ( (IP.GT.1)      .AND.(IRESP.GT.1).AND.
19575      &              (NOBAM(I).NE.1).AND.(NPW.GT.0)        ) THEN
19576 *     Lorentz-trsf. into proj. rest sys. for those being inside proj.
19577                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19578      &                        PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
19579      &                        PLAB(1,4),ID,-2)
19580                   PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
19581                   PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
19582      &                                  (PLAB(1,4)+PLABT) ))
19583                   EKIN = PLAB(1,4)-PLAB(1,5)
19584                   IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
19585                   IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
19586                ENDIF
19587                IF ( (IT.GT.1)      .AND.(IREST.GT.1).AND.
19588      &              (NOBAM(I).NE.2).AND.(NTW.GT.0)        ) THEN
19589 *     Lorentz-trsf. into targ. rest sys. for those being inside targ.
19590                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19591      &                        PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
19592      &                        PLAB(2,4),ID,-3)
19593                   PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
19594                   PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
19595      &                                  (PLAB(2,4)+PLABT) ))
19596                   EKIN = PLAB(2,4)-PLAB(2,5)
19597                   IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
19598                   IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
19599                ENDIF
19600                IF (PHKK(3,I).GE.ZERO) THEN
19601                   ISTHKK(I) = NPOTT
19602                   IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
19603                ELSE
19604                   ISTHKK(I) = NPOTP
19605                   IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
19606                ENDIF
19607                IF (ISTHKK(I).NE.1) THEN
19608                   J = ISTHKK(I)-14
19609                   DO 4 K=1,5
19610                      PHKK(K,I) = PLAB(J,K)
19611     4             CONTINUE
19612                   IF (ISTHKK(I).EQ.15) THEN
19613                      NPW = NPW-1
19614                      IF (ID.EQ.1) NPCW = NPCW-1
19615                      DO 9 K=1,4
19616                         TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19617     9                CONTINUE
19618                   ELSEIF (ISTHKK(I).EQ.16) THEN
19619                      NTW = NTW-1
19620                      IF (ID.EQ.1) NTCW = NTCW-1
19621                      DO 10 K=1,4
19622                         TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19623    10                CONTINUE
19624                   ENDIF
19625                ENDIF
19626             ENDIF
19627          ENDIF
19628     3 CONTINUE
19629
19630 * again: get nuclear potential corresp. to the residual nucleus
19631       IPRCL  = IP -NPW
19632       IPZRCL = IPZ-NPCW
19633       ITRCL  = IT -NTW
19634       ITZRCL = ITZ-NTCW
19635 c      AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
19636 cC     AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
19637 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
19638 C     AFERP = 0.0D0
19639 c      AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
19640 cC     AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
19641 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
19642 C     AFERT = 0.0D0
19643 C     IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
19644 C     IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
19645 C     IF (AFERP.GT.0.85D0) AFERP = 0.85D0
19646 C     IF (AFERT.GT.0.85D0) AFERT = 0.85D0
19647       AFERP = FERMOD+0.1D0
19648       AFERT = FERMOD+0.1D0
19649
19650       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
19651
19652       RETURN
19653       END
19654
19655 *$ CREATE DT_FICONF.FOR
19656 *COPY DT_FICONF
19657 *
19658 *===ficonf=============================================================*
19659 *
19660       SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
19661
19662 ************************************************************************
19663 * Treatment of FInal CONFiguration including evaporation, fission and  *
19664 * Fermi-break-up (for light nuclei only).                              *
19665 * Adopted from the original routine FINALE and extended to residual    *
19666 * projectile nuclei.                                                   *
19667 * This version dated 12.12.95 is written by S. Roesler.                *
19668 *                                                                      *
19669 * Last change 27.12.2006 by S. Roesler.                                *
19670 ************************************************************************
19671
19672       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19673       SAVE
19674
19675       PARAMETER ( LINP = 10 ,
19676      &            LOUT = 6 ,
19677      &            LDAT = 9 )
19678
19679       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
19680       PARAMETER (ANGLGB=5.0D-16)
19681
19682 * event history
19683
19684       PARAMETER (NMXHKK=200000)
19685
19686       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19687      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19688      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19689
19690 * extended event history
19691       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19692      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19693      &                IHIST(2,NMXHKK)
19694
19695 * rejection counter
19696       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
19697      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
19698      &                IREXCI(3),IRDIFF(2),IRINC
19699
19700 * central particle production, impact parameter biasing
19701       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
19702
19703 * particle properties (BAMJET index convention)
19704       CHARACTER*8  ANAME
19705       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19706      &                IICH(210),IIBAR(210),K1(210),K2(210)
19707
19708 * treatment of residual nuclei: 4-momenta
19709       LOGICAL LRCLPR,LRCLTA
19710       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19711      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19712
19713 * treatment of residual nuclei: properties of residual nuclei
19714       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19715      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19716      &                NTOTFI(2),NPROFI(2)
19717
19718 * statistics: residual nuclei
19719       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19720      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19721      &                NINCST(2,4),NINCEV(2),
19722      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19723      &                NRESPB(2),NRESCH(2),NRESEV(4),
19724      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19725      &                NEVAFI(2,2)
19726
19727 * flags for input different options
19728       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19729       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19730      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19731
19732 *      INCLUDE '(DIMPAR)'
19733 *     DIMPAR taken from FLUKA
19734       PARAMETER ( MXXRGN =20000 )
19735       PARAMETER ( MXXMDF =  710 )
19736       PARAMETER ( MXXMDE =  702 )
19737       PARAMETER ( MFSTCK =40000 )
19738       PARAMETER ( MESTCK =  100 )
19739       PARAMETER ( MOSTCK = 2000 )
19740       PARAMETER ( MXPRSN =  100 )
19741       PARAMETER ( MXPDPM =  800 )
19742       PARAMETER ( MXPSCS =30000 )
19743       PARAMETER ( MXGLWN =  300 )
19744       PARAMETER ( MXOUTU =   50 )
19745       PARAMETER ( NALLWP =   64 )
19746       PARAMETER ( NELEMX =   80 )
19747       PARAMETER ( MPDPDX =   18 )
19748       PARAMETER ( MXHTTR =  260 )
19749       PARAMETER ( MXSEAX =   20 )
19750       PARAMETER ( MXHTNC = MXSEAX + 1 )
19751       PARAMETER ( ICOMAX = 2400 )
19752       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
19753       PARAMETER ( NSTBIS =  304 )
19754       PARAMETER ( NQSTIS =   46 )
19755       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
19756       PARAMETER ( MXPABL =  120 )
19757       PARAMETER ( IDMAXP =  450 )
19758       PARAMETER ( IDMXDC = 2000 )
19759       PARAMETER ( MXMCIN =  410 )
19760       PARAMETER ( IHYPMX =    4 )
19761       PARAMETER ( MKBMX1 =   11 )
19762       PARAMETER ( MKBMX2 =   11 )
19763       PARAMETER ( MXIRRD = 2500 )
19764       PARAMETER ( MXTRDC = 1500 )
19765       PARAMETER ( NKTL   =   17 )
19766       PARAMETER ( NBLNMX = 40000000 )
19767
19768 *      INCLUDE '(GENSTK)'
19769 *     GENSTK taken from FLUKA
19770       COMMON / GENSTK /                CXR    (MXPSCS), CYR    (MXPSCS),
19771      &                CZR    (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
19772      &                CZRPOL (MXPSCS), TKI    (MXPSCS), PLR    (MXPSCS),
19773      &                WEI    (MXPSCS), AGESEC (MXPSCS), TV    , TVCMS  ,
19774      &                TVRECL,  TVHEAV, TVBIND,
19775      &                KPART  (MXPSCS), INFEXT (MXPSCS), NP0   , NP
19776
19777 *      INCLUDE '(RESNUC)'
19778 *     RESNUC from FLUKA
19779       LOGICAL LRNFSS, LFRAGM
19780       COMMON /RESNUC/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19781      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19782      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
19783      &                  PYRES,  PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
19784      &                 ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
19785      &                  KTARP,  KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
19786      &                 IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,  ICRES,
19787      &                  IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
19788      &                 IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
19789      &                 IEV4HE, IDEEXG,  IBTAR, ICHTAR, IBLEFT, ICLEFT,
19790      &                 ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
19791      &                 LRNFSS, LFRAGM
19792
19793       PARAMETER ( EMVGEV = 1.0                D-03 )
19794       PARAMETER ( AMUGEV = 0.93149432         D+00 )
19795       PARAMETER ( AMPRTN = 0.93827231         D+00 )
19796       PARAMETER ( AMNTRN = 0.93956563         D+00 )
19797       PARAMETER ( AMELCT = 0.51099906         D-03 )
19798       PARAMETER ( ELCCGS = 4.8032068          D-10 )
19799       PARAMETER ( ELCMKS = 1.60217733         D-19 )
19800       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19801      &                   * 1.D-09 )
19802       PARAMETER ( HLFHLF = 0.5D+00 )
19803       PARAMETER ( FERTHO = 14.33       D-09 )
19804       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
19805       PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
19806       PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
19807
19808 *      INCLUDE '(NUCDAT)'
19809 *     Taken from FLUKA
19810       PARAMETER ( AMUAMU = AMUGEV )
19811       PARAMETER ( AMPROT = AMPRTN )
19812       PARAMETER ( AMNEUT = AMNTRN )
19813       PARAMETER ( AMELEC = AMELCT )
19814       PARAMETER ( R0NUCL = 1.12        D+00 )
19815       PARAMETER ( RCCOUL = 1.7         D+00 )
19816       PARAMETER ( COULPR = COUGFM )
19817       PARAMETER ( AMHYDR = AMPRTN + AMELCT  )
19818       PARAMETER ( AMHTON = AMHYDR - AMNTRN  )
19819       PARAMETER ( AMNTOU = AMNTRN - AMUC12  )
19820       PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
19821       PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
19822 *   Gammin : threshold for deexcitation gammas production, set to 1 keV
19823 *   (this means that up to 1 keV of energy unbalancing can occur
19824 *    during an event)
19825       PARAMETER ( GAMMIN = 1.0D-06 )
19826       PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
19827 *   Tvepsi : "epsilon" for excitation energy, set to gammin / 100
19828       PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
19829 *
19830       COMMON /NUCDAT/ AV0WEL,     APFRMX,     AEFRMX,     AEFRMA,
19831      &                RDSNUC,     V0WELL (2), PFRMMX (2), EFRMMX (2),
19832      &                EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
19833      &                VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
19834      &                PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
19835      &                EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
19836      &                ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV    ,
19837      &                AMRCSQ    , ATO1O3    , ZTO1O3    , FRMRFC    ,
19838      &                ELBNDE (0:110)
19839
19840 *      INCLUDE '(PAREVT)'
19841 *     Taken from FLUKA
19842       PARAMETER ( FRDIFF = 0.2D+00 )
19843       PARAMETER ( ETHSEA = 1.0D+00 )
19844 *
19845       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
19846      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
19847      &        LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
19848      &        LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
19849       COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
19850      &                  LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
19851      &                  LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
19852      &                  LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
19853      &                  LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
19854      &                  LVP2XX, LV2XNW, LNWV2X, LEVFIN
19855
19856 *      INCLUDE '(FHEAVY)'
19857 *     Taken from FLUKA
19858       PARAMETER ( MXHEAV = 100 )
19859       PARAMETER ( KXHEAV =  30 )
19860       CHARACTER*8 ANHEAV
19861       COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19862      &                  CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19863      &                  PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19864      &                  AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
19865      &                  AMHEAV (KXHEAV), AMNHEA (KXHEAV),
19866      &                  KHEAVY (MXHEAV), INFHEA (MXHEAV),
19867      &                  ICHEAV (KXHEAV), IBHEAV (KXHEAV),
19868      &                  IMHEAV (KXHEAV), IHHEAV (KXHEAV),
19869      &                  KHHEAV (IHYPMX,KXHEAV), NPHEAV
19870       COMMON / FHEAVC / ANHEAV (KXHEAV)
19871
19872 * event flag
19873       COMMON /DTEVNO/ NEVENT,ICASCA
19874
19875       DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
19876      &          PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
19877      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
19878
19879       DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
19880       LOGICAL LLCPOT
19881       DATA EXC,NEXC /520*ZERO,520*0/
19882       DATA EXPNUC /4.0D-3,4.0D-3/
19883
19884       IREJ   = 0
19885       LRCLPR = .FALSE.
19886       LRCLTA = .FALSE.
19887
19888 * skip residual nucleus treatment if not requested or in case
19889 * of central collisions
19890       IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
19891
19892       DO 1 K=1,2
19893          IDPAR(K) = 0
19894          IDXPAR(K)= 0
19895          NTOT(K)  = 0
19896          NTOTFI(K)= 0
19897          NPRO(K)  = 0
19898          NPROFI(K)= 0
19899          NN(K)    = 0
19900          NH(K)    = 0
19901          NHPOS(K) = 0
19902          NQ(K)    = 0
19903          EEXC(K)  = ZERO
19904          MO1(K)   = 0
19905          MO2(K)   = 0
19906          DO 2 I=1,4
19907             VRCL(K,I) = ZERO
19908             WRCL(K,I) = ZERO
19909     2    CONTINUE
19910     1 CONTINUE
19911       NFSP = 0
19912       INUC(1) = IP
19913       INUC(2) = IT
19914
19915       DO 3 I=1,NHKK
19916
19917 * number of final state particles
19918          IF (ABS(ISTHKK(I)).EQ.1) THEN
19919             NFSP  = NFSP+1
19920             IDFSP = IDBAM(I)
19921          ENDIF
19922
19923 * properties of remaining nucleon configurations
19924          KF = 0
19925          IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
19926          IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
19927          IF (KF.GT.0) THEN
19928             IF (MO1(KF).EQ.0) MO1(KF) = I
19929             MO2(KF)  = I
19930 *   position of residual nucleus = average position of nucleons
19931             DO 4 K=1,4
19932                VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
19933                WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
19934     4       CONTINUE
19935 *   total number of particles contributing to each residual nucleus
19936             NTOT(KF)  = NTOT(KF)+1
19937             IDTMP     = IDBAM(I)
19938             IDXTMP    = I
19939 *   total charge of residual nuclei
19940             NQ(KF) = NQ(KF)+IICH(IDTMP)
19941 *   number of protons
19942             IF (IDHKK(I).EQ.2212) THEN
19943                NPRO(KF) = NPRO(KF)+1
19944 *   number of neutrons
19945             ELSEIF (IDHKK(I).EQ.2112) THEN
19946                NN(KF) = NN(KF)+1
19947             ELSE
19948 *   number of baryons other than n, p
19949                IF (IIBAR(IDTMP).EQ.1) THEN
19950                   NH(KF) = NH(KF)+1
19951                   IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
19952                ELSE
19953 *   any other mesons (status set to 1)
19954 C                 WRITE(LOUT,1002) KF,IDTMP
19955 C1002             FORMAT(1X,'FICONF:   residual nucleus ',I2,
19956 C    &                   ' containing meson ',I4,', status set to 1')
19957                   ISTHKK(I) = 1
19958                   IDTMP     = IDPAR(KF)
19959                   IDXTMP    = IDXPAR(KF)
19960                   NTOT(KF)  = NTOT(KF)-1
19961                ENDIF
19962             ENDIF
19963             IDPAR(KF)  = IDTMP
19964             IDXPAR(KF) = IDXTMP
19965          ENDIF
19966     3 CONTINUE
19967
19968 * reject elastic events (def: one final state particle = projectile)
19969       IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
19970          IREXCI(3) = IREXCI(3)+1
19971          GOTO 9999
19972 C        RETURN
19973       ENDIF
19974
19975 * check if one nucleus disappeared..
19976 C     IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
19977 C        DO 5 K=1,4
19978 C           PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
19979 C           PRCLPR(K) = ZERO
19980 C   5    CONTINUE
19981 C     ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
19982 C        DO 6 K=1,4
19983 C           PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
19984 C           PRCLTA(K) = ZERO
19985 C   6    CONTINUE
19986 C     ENDIF
19987
19988       ICOR   = 0
19989       INORCL = 0
19990       DO 7 I=1,2
19991          DO 8 K=1,4
19992 * get the average of the nucleon positions
19993             VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
19994             WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
19995             IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
19996             IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
19997     8    CONTINUE
19998 * mass number and charge of residual nuclei
19999          AIF(I)  = DBLE(NTOT(I))
20000          AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
20001          IF (NTOT(I).GT.1) THEN
20002 * masses of residual nuclei in ground state
20003
20004 C           AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I))
20005             AMRCL0(I) = AIF(I)*AMUC12
20006      &                  +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM)
20007
20008 * masses of residual nuclei
20009             PTORCL   = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
20010             AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
20011             IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
20012 *
20013 *   M_res^2 < 0 : configuration not allowed
20014 *
20015 *      a) re-calculate E_exc with scaled nuclear potential
20016 *         (conditional jump to label 9998)
20017 *      b) or reject event if N_loop(max) is exceeded
20018 *         (conditional jump to label 9999)
20019 *
20020             IF (AMRCL(I).LE.ZERO) THEN
20021                IF (IOULEV(3).GT.0)
20022      &            WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
20023      &                             PRCL(I,4),NTOT
20024  1000          FORMAT(1X,'warning! negative excitation energy',/,
20025      &                I4,4E15.4,2I4)
20026                AMRCL(I) = ZERO
20027                EEXC(I)  = ZERO
20028                IF (NLOOP.LE.500) THEN
20029                   GOTO 9998
20030                ELSE
20031                   IREXCI(2) = IREXCI(2)+1
20032                   GOTO 9999
20033                ENDIF
20034 *
20035 *   0 < M_res < M_res0 : mass below ground-state mass
20036 *
20037 *      a) we had residual nuclei with mass N_tot and reasonable E_exc
20038 *         before- assign average E_exc of those configurations to this
20039 *         one ( Nexc(i,N_tot) > 0 )
20040 *      b) or (and this applies always if run in transport codes) go up
20041 *         one mass number and
20042 *           i) if mass now larger than proj/targ mass or if run in
20043 *              transport codes assign average E_exc per wounded nucleon
20044 *              x number of wounded nucleons (Inuc-Ntot)
20045 *          ii) or assign average E_exc of those configurations to this
20046 *              one ( Nexc(i,m) > 0 )
20047 *
20048             ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
20049      &                                                         THEN
20050                M = MIN(NTOT(I),260)
20051                IF (NEXC(I,M).GT.0) THEN
20052                   AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20053                ELSE
20054    70             CONTINUE
20055                   M = M+1
20056 **sr corrected 27.12.06
20057 *                 IF (M.GE.INUC(I)) THEN
20058 *                    AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
20059                   IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
20060                      IF ( INUC (I) .GT. NTOT (I) ) THEN
20061                         AMRCL(I) = AMRCL0(I)
20062      &                         + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
20063                      ELSE
20064                         AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
20065                      END IF
20066 **
20067                   ELSE
20068                      IF (NEXC(I,M).GT.0) THEN
20069                         AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20070                      ELSE
20071                         GOTO 70
20072                      ENDIF
20073                   ENDIF
20074                ENDIF
20075                EEXC(I)  = AMRCL(I)-AMRCL0(I)
20076                ICOR     = ICOR+I
20077 *
20078 *   M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
20079 *
20080 *      a) re-calculate E_exc with scaled nuclear potential
20081 *         (conditional jump to label 9998)
20082 *      b) or reject event if N_loop(max) is exceeded
20083 *         (conditional jump to label 9999)
20084 *
20085 *
20086             ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
20087                IF (IOULEV(3).GT.0)
20088      &            WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
20089  1004          FORMAT(1X,'warning! too high excitation energy',/,
20090      &                I4,1P,2E15.4,3I5)
20091                AMRCL(I) = ZERO
20092                EEXC(I)  = ZERO
20093                IF (NLOOP.LE.500) THEN
20094                   GOTO 9998
20095                ELSE
20096                   IREXCI(2) = IREXCI(2)+1
20097                   GOTO 9999
20098                ENDIF
20099 *
20100 *   Otherwise (reasonable E_exc) :
20101 *      E_exc = M_res - M_res0
20102 *      in addition: calculate and save E_exc per wounded nucleon as
20103 *                   well as E_exc in <E_exc> counter
20104 *
20105             ELSE
20106 * excitation energies of residual nuclei
20107                EEXC(I)   = AMRCL(I)-AMRCL0(I)
20108 **sr 27.12.06 new excitation energy correction by A.F.
20109 *
20110 * all parts with Ilcopt<3 commented since not used
20111 *
20112 * still to be done/decided:
20113 *   Increase Icor and put back both residual nuclei on mass shell
20114 *   with the exciting correction further below.
20115 *   For the moment the modification in the excitation energy is simply
20116 *   corrected by scaling the energy of the residual nucleus.
20117 *
20118                LLCPOT = .TRUE.
20119                ILCOPT = 3
20120                IF ( LLCPOT ) THEN
20121                   NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
20122                   IF ( ILCOPT .LE. 2 ) THEN
20123 C* Patch for Fermi momentum reduction correlated with impact parameter:
20124 C                     FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
20125 C                     DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
20126 C                     AKPRHO = ONE - DLKPRH
20127 C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
20128 C                     FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO  - ONE,
20129 C     &                              0.05D+00 )
20130 C*                    REDORI = 0.75D+00
20131 C*                    REDORI = ONE
20132 C                     REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20133                   ELSE
20134                      DLKPRH = ZERO
20135                      RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
20136 *  Take out roughly one/half of the skin:
20137                      RDCORE = RDCORE - 0.5D+00
20138                      FRCFLL = RDCORE**3
20139                      PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
20140                      PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
20141                      FRCFLL = ONE - PRSKIN
20142                      FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
20143                      REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20144                   END IF
20145                   IF ( NNCHIT .GT. 0 ) THEN
20146 C                     IF ( ILCOPT .EQ. 1 ) THEN
20147 C                        SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
20148 C                        DO 1220 NCH = 1, 10
20149 C                           ETAETA = ( ONE - SKINRH**INUC(I)
20150 C     &                            - DBLE(INUC(I))* ( ONE - FRCFLL )
20151 C     &                            * ( ONE - SKINRH ) )
20152 C     &                            / ( SKINRH**INUC(I) - DBLE (INUC(I))
20153 C     &                            * ( ONE - FRCFLL) * SKINRH )
20154 C                           SKINRH = SKINRH * ( ONE + ETAETA )
20155 C 1220                   CONTINUE
20156 C                        PRSKIN = SKINRH**(NNCHIT-1)
20157 C                     ELSE IF ( ILCOPT .EQ. 2 ) THEN
20158 C                        PRSKIN = ONE - FRCFLL
20159 C                     END IF
20160                      REDCTN = ZERO
20161                      DO 1230 NCH = 1, NNCHIT
20162                         IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
20163                            PRFRMI = (( ONE - 2.D+00 * DLKPRH )
20164      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
20165                         ELSE
20166                            PRFRMI = ( ONE - 2.D+00 * DLKPRH
20167      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
20168                         END IF
20169                         REDCTN = REDCTN + PRFRMI**2
20170  1230                CONTINUE
20171                      REDCTN = REDCTN / DBLE (NNCHIT)
20172                   ELSE
20173                      REDCTN = 0.5D+00
20174                   END IF
20175                   EEXC  (I) = EEXC   (I) * REDCTN / REDORI
20176                   AMRCL (I) = AMRCL0 (I) + EEXC (I)
20177                   PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
20178                END IF
20179 **
20180                IF (ICASCA.EQ.0) THEN
20181                   EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
20182                   M = MIN(NTOT(I),260)
20183                   EXC(I,M)  = EXC(I,M)+EEXC(I)
20184                   NEXC(I,M) = NEXC(I,M)+1
20185                ENDIF
20186             ENDIF
20187          ELSEIF (NTOT(I).EQ.1) THEN
20188             WRITE(LOUT,1003) I
20189  1003       FORMAT(1X,'FICONF:   warning! NTOT(I)=1? (I=',I3,')')
20190             GOTO 9999
20191          ELSE
20192             AMRCL0(I) = ZERO
20193             AMRCL(I)  = ZERO
20194             EEXC(I)   = ZERO
20195             INORCL    = INORCL+I
20196          ENDIF
20197     7 CONTINUE
20198
20199       PRCLPR(5) = AMRCL(1)
20200       PRCLTA(5) = AMRCL(2)
20201
20202       IF (ICOR.GT.0) THEN
20203          IF (INORCL.EQ.0) THEN
20204 * one or both residual nuclei consist of one nucleon only, transform
20205 * this nucleon on mass shell
20206             DO 9 K=1,4
20207                P1IN(K) = PRCL(1,K)
20208                P2IN(K) = PRCL(2,K)
20209     9       CONTINUE
20210             XM1 = AMRCL(1)
20211             XM2 = AMRCL(2)
20212             CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
20213             IF (IREJ1.GT.0) THEN
20214                WRITE(LOUT,*) 'ficonf-mashel rejection'
20215                GOTO 9999
20216             ENDIF
20217             DO 10 K=1,4
20218                PRCL(1,K) = P1OUT(K)
20219                PRCL(2,K) = P2OUT(K)
20220                PRCLPR(K) = P1OUT(K)
20221                PRCLTA(K) = P2OUT(K)
20222    10       CONTINUE
20223             PRCLPR(5) = AMRCL(1)
20224             PRCLTA(5) = AMRCL(2)
20225          ELSE
20226             IF (IOULEV(3).GT.0)
20227      &      WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
20228      &                       INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
20229      &                       AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
20230      &                       AMRCL(2),AMRCL(2)-AMRCL0(2)
20231  1001       FORMAT(1X,'FICONF:   warning! no residual nucleus for',
20232      &             ' correction',/,11X,'at event',I8,
20233      &             ',  nucleon config. 1:',2I4,' 2:',2I4,
20234      &             2(/,11X,3E12.3))
20235             IF (NLOOP.LE.500) THEN
20236                GOTO 9998
20237             ELSE
20238                IREXCI(1) = IREXCI(1)+1
20239             ENDIF
20240          ENDIF
20241       ENDIF
20242
20243 * update counter
20244 C     IF (NRESEV(1).NE.NEVHKK) THEN
20245 C        NRESEV(1) = NEVHKK
20246 C        NRESEV(2) = NRESEV(2)+1
20247 C     ENDIF
20248       NRESEV(2) = NRESEV(2)+1
20249       DO 15 I=1,2
20250          EXCDPM(I)   = EXCDPM(I)+EEXC(I)
20251          EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
20252          NRESTO(I) = NRESTO(I)+NTOT(I)
20253          NRESPR(I) = NRESPR(I)+NPRO(I)
20254          NRESNU(I) = NRESNU(I)+NN(I)
20255          NRESBA(I) = NRESBA(I)+NH(I)
20256          NRESPB(I) = NRESPB(I)+NHPOS(I)
20257          NRESCH(I) = NRESCH(I)+NQ(I)
20258    15 CONTINUE
20259
20260 * evaporation
20261       IF (LEVPRT) THEN
20262          DO 13 I=1,2
20263 * initialize evaporation counter
20264             EEXCFI(I) = ZERO
20265             IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
20266      &          (EEXC(I).GT.ZERO)) THEN
20267 * put residual nuclei into DTEVT1
20268                IDRCL = 80000
20269                JMASS = INT( AIF(I))
20270                JCHAR = INT(AIZF(I))
20271 *  the following patch is required to transmit the correct excitation
20272 *   energy to Eventd
20273                IF (ITRSPT.EQ.1) THEN
20274                   IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
20275      &                (IOULEV(3).GT.0))
20276      &               WRITE(LOUT,*)
20277      &                  ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
20278      &                              AMRCL(I),AMRCL0(I),EEXC(I)
20279                   PRCL0 = PRCL(I,4)
20280                   PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
20281      &                                                    +PRCL(I,3)**2)
20282                   IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
20283                      WRITE(LOUT,*)
20284      &                  ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
20285                   ENDIF
20286                ENDIF
20287                CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
20288      &              PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
20289 **sr 22.6.97
20290                NOBAM(NHKK) = I
20291 **
20292                DO 14 J=1,4
20293                   VHKK(J,NHKK) = VRCL(I,J)
20294                   WHKK(J,NHKK) = WRCL(I,J)
20295    14          CONTINUE
20296 *  interface to evaporation module - fill final residual nucleus into
20297 *  common FKRESN
20298 *   fill resnuc only if code is not used as event generator in Fluka
20299                IF (ITRSPT.NE.1) THEN
20300                   PXRES  = PRCL(I,1)
20301                   PYRES  = PRCL(I,2)
20302                   PZRES  = PRCL(I,3)
20303                   IBRES  = NPRO(I)+NN(I)+NH(I)
20304                   ICRES  = NPRO(I)+NHPOS(I)
20305                   ANOW   = DBLE(IBRES)
20306                   ZNOW   = DBLE(ICRES)
20307                   PTRES  = SQRT(PXRES**2+PYRES**2+PZRES**2)
20308 *   ground state mass of the residual nucleus (should be equal to AM0T)
20309
20310                   AMNRES = AMRCL0(I)
20311                   AMMRES = AMNAMA ( AMNRES, IBRES, ICRES )
20312
20313 *  common FKFINU
20314                   TV = ZERO
20315 *   kinetic energy of residual nucleus
20316                   TVRECL = PRCL(I,4)-AMRCL(I)
20317 *   excitation energy of residual nucleus
20318                   TVCMS  = EEXC(I)
20319                   PTOLD  = PTRES
20320                   PTRES  = SQRT(ABS(TVRECL*(TVRECL+
20321      &                          2.0D0*(AMMRES+TVCMS))))
20322                   IF (PTOLD.LT.ANGLGB) THEN
20323                      CALL DT_RACO(PXRES,PYRES,PZRES)
20324                      PTOLD = ONE
20325                   ENDIF
20326                   PXRES = PXRES*PTRES/PTOLD
20327                   PYRES = PYRES*PTRES/PTOLD
20328                   PZRES = PZRES*PTRES/PTOLD
20329 * zero counter of secondaries from evaporation
20330                   NP = 0
20331 * evaporation
20332                   WE = ONE
20333
20334                   NPHEAV = 0
20335                   LRNFSS = .FALSE.
20336                   LFRAGM = .FALSE.
20337                   CALL EVEVAP(WE)
20338
20339 * put evaporated particles and residual nuclei to DTEVT1
20340                   MO = NHKK
20341                   CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
20342                ENDIF
20343                EEXCFI(I) = EXCITF
20344                EXCEVA(I) = EXCEVA(I)+EXCITF
20345             ENDIF
20346    13    CONTINUE
20347       ENDIF
20348
20349       RETURN
20350
20351 C9998 IREXCI(1) = IREXCI(1)+1
20352  9998 IREJ   = IREJ+1
20353  9999 CONTINUE
20354       LRCLPR = .TRUE.
20355       LRCLTA = .TRUE.
20356       IREJ   = IREJ+1
20357       RETURN
20358       END
20359
20360 *$ CREATE DT_EVA2HE.FOR
20361 *COPY DT_EVA2HE
20362 *                                                                      *
20363 *====eva2he============================================================*
20364 *                                                                      *
20365       SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
20366
20367 ************************************************************************
20368 * Interface between common's of evaporation module (FKFINU,FKFHVY)     *
20369 * and DTEVT1.                                                          *
20370 *    MO    DTEVT1-index of "mother" (residual) nucleus before evap.    *
20371 *    EEXCF exitation energy of residual nucleus after evaporation      *
20372 *    IRCL  = 1 projectile residual nucleus                             *
20373 *          = 2 target     residual nucleus                             *
20374 * This version dated 19.04.95 is written by S. Roesler.                *
20375 *                                                                      *
20376 * Last change 27.12.2006 by S. Roesler.                                *
20377 ************************************************************************
20378
20379       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20380       SAVE
20381
20382       PARAMETER ( LINP = 10 ,
20383      &            LOUT = 6 ,
20384      &            LDAT = 9 )
20385
20386       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
20387
20388 * event history
20389
20390       PARAMETER (NMXHKK=200000)
20391
20392       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
20393      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
20394      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
20395 * Note: DTEVT2 - special use for heavy fragments !
20396 *       (IDRES(I) = mass number, IDXRES(I) = charge)
20397
20398 * extended event history
20399       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
20400      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
20401      &                IHIST(2,NMXHKK)
20402
20403 * particle properties (BAMJET index convention)
20404       CHARACTER*8  ANAME
20405       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20406      &                IICH(210),IIBAR(210),K1(210),K2(210)
20407
20408 * flags for input different options
20409       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20410       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20411      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20412
20413 * statistics: residual nuclei
20414       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
20415      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
20416      &                NINCST(2,4),NINCEV(2),
20417      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
20418      &                NRESPB(2),NRESCH(2),NRESEV(4),
20419      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
20420      &                NEVAFI(2,2)
20421
20422 * treatment of residual nuclei: properties of residual nuclei
20423       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
20424      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
20425      &                NTOTFI(2),NPROFI(2)
20426
20427 *      INCLUDE '(DIMPAR)'
20428 *     Taken from FLUKA
20429       PARAMETER ( MXXRGN =20000 )
20430       PARAMETER ( MXXMDF =  710 )
20431       PARAMETER ( MXXMDE =  702 )
20432       PARAMETER ( MFSTCK =40000 )
20433       PARAMETER ( MESTCK =  100 )
20434       PARAMETER ( MOSTCK = 2000 )
20435       PARAMETER ( MXPRSN =  100 )
20436       PARAMETER ( MXPDPM =  800 )
20437       PARAMETER ( MXPSCS =30000 )
20438       PARAMETER ( MXGLWN =  300 )
20439       PARAMETER ( MXOUTU =   50 )
20440       PARAMETER ( NALLWP =   64 )
20441       PARAMETER ( NELEMX =   80 )
20442       PARAMETER ( MPDPDX =   18 )
20443       PARAMETER ( MXHTTR =  260 )
20444       PARAMETER ( MXSEAX =   20 )
20445       PARAMETER ( MXHTNC = MXSEAX + 1 )
20446       PARAMETER ( ICOMAX = 2400 )
20447       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
20448       PARAMETER ( NSTBIS =  304 )
20449       PARAMETER ( NQSTIS =   46 )
20450       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
20451       PARAMETER ( MXPABL =  120 )
20452       PARAMETER ( IDMAXP =  450 )
20453       PARAMETER ( IDMXDC = 2000 )
20454       PARAMETER ( MXMCIN =  410 )
20455       PARAMETER ( IHYPMX =    4 )
20456       PARAMETER ( MKBMX1 =   11 )
20457       PARAMETER ( MKBMX2 =   11 )
20458       PARAMETER ( MXIRRD = 2500 )
20459       PARAMETER ( MXTRDC = 1500 )
20460       PARAMETER ( NKTL   =   17 )
20461       PARAMETER ( NBLNMX = 40000000 )
20462
20463 *      INCLUDE '(GENSTK)'
20464 *     Taken from FLUKA
20465       PARAMETER ( MXP = MXPSCS )
20466 *
20467       COMMON / GENSTK /                CXR    (MXPSCS), CYR    (MXPSCS),
20468      &                CZR    (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
20469      &                CZRPOL (MXPSCS), TKI    (MXPSCS), PLR    (MXPSCS),
20470      &                WEI    (MXPSCS), AGESEC (MXPSCS), TV    , TVCMS  ,
20471      &                TVRECL,  TVHEAV, TVBIND,
20472      &                KPART  (MXPSCS), INFEXT (MXPSCS), NP0   , NP
20473
20474 *      INCLUDE '(RESNUC)'
20475       LOGICAL LRNFSS, LFRAGM
20476       COMMON /RESNUC/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
20477      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
20478      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
20479      &                  PYRES,  PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
20480      &                 ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
20481      &                  KTARP,  KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
20482      &                 IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,  ICRES,
20483      &                  IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
20484      &                 IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
20485      &                 IEV4HE, IDEEXG,  IBTAR, ICHTAR, IBLEFT, ICLEFT,
20486      &                 ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
20487      &                 LRNFSS, LFRAGM
20488 *     Taken from FLUKA
20489
20490 *      INCLUDE '(FHEAVY)'
20491 *     Taken from FLUKA
20492       PARAMETER ( MXHEAV = 100 )
20493       PARAMETER ( KXHEAV =  30 )
20494       CHARACTER*8 ANHEAV
20495       COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20496      &                  CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20497      &                  PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20498      &                  AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
20499      &                  AMHEAV (KXHEAV), AMNHEA (KXHEAV),
20500      &                  KHEAVY (MXHEAV), INFHEA (MXHEAV),
20501      &                  ICHEAV (KXHEAV), IBHEAV (KXHEAV),
20502      &                  IMHEAV (KXHEAV), IHHEAV (KXHEAV),
20503      &                  KHHEAV (IHYPMX,KXHEAV), NPHEAV
20504       COMMON / FHEAVC / ANHEAV (KXHEAV)
20505
20506       DIMENSION IPTOKP(39)
20507       DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
20508      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
20509      & 100, 101, 97, 102, 98, 103, 109, 115 /
20510
20511       IREJ = 0
20512
20513 * skip if evaporation package is not included
20514       IF (.NOT.LEVAPO) RETURN
20515
20516 * update counter
20517       IF (NRESEV(3).NE.NEVHKK) THEN
20518          NRESEV(3) = NEVHKK
20519          NRESEV(4) = NRESEV(4)+1
20520       ENDIF
20521
20522       IF (LEMCCK)
20523      &   CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
20524      &                                                   IDUM,IDUM)
20525 * mass number/charge of residual nucleus before evaporation
20526       IBTOT = IDRES(MO)
20527       IZTOT = IDXRES(MO)
20528
20529 * protons/neutrons/gammas
20530       DO 1 I=1,NP
20531          PX    = CXR(I)*PLR(I)
20532          PY    = CYR(I)*PLR(I)
20533          PZ    = CZR(I)*PLR(I)
20534          ID    = IPTOKP(KPART(I))
20535          IDPDG = IDT_IPDGHA(ID)
20536          AM    = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
20537      &           (2.0D0*MAX(TKI(I),TINY10))
20538          IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
20539             WRITE(LOUT,1000) ID,AM,AAM(ID)
20540  1000       FORMAT(1X,'EVA2HE:  inconsistent mass of evap. ',
20541      &             'particle',I3,2E10.3)
20542          ENDIF
20543          PE = TKI(I)+AM
20544          CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
20545          NOBAM(NHKK) = IRCL
20546          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20547          IBTOT = IBTOT-IIBAR(ID)
20548          IZTOT = IZTOT-IICH(ID)
20549     1 CONTINUE
20550
20551 * heavy fragments
20552       DO 2 I=1,NPHEAV
20553          PX     = CXHEAV(I)*PHEAVY(I)
20554          PY     = CYHEAV(I)*PHEAVY(I)
20555          PZ     = CZHEAV(I)*PHEAVY(I)
20556          IDHEAV = 80000
20557          AM     = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
20558      &            (2.0D0*MAX(TKHEAV(I),TINY10))
20559          PE     = TKHEAV(I)+AM
20560          CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
20561      &                  IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
20562          NOBAM(NHKK) = IRCL
20563          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20564          IBTOT = IBTOT-IBHEAV(KHEAVY(I))
20565          IZTOT = IZTOT-ICHEAV(KHEAVY(I))
20566     2 CONTINUE
20567
20568       IF (IBRES.GT.0) THEN
20569 * residual nucleus after evaporation
20570          IDNUC = 80000
20571          CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
20572      &                                        IBRES,ICRES,0)
20573          NOBAM(NHKK) = IRCL
20574       ENDIF
20575       EEXCF = TVCMS
20576       NTOTFI(IRCL) = IBRES
20577       NPROFI(IRCL) = ICRES
20578       IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
20579       IBTOT = IBTOT-IBRES
20580       IZTOT = IZTOT-ICRES
20581
20582 * count events with fission
20583       NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
20584       IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
20585
20586 * energy-momentum conservation check
20587       IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
20588 C     IF (IREJ.GT.0) THEN
20589 C        CALL DT_EVTOUT(4)
20590 C        WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
20591 C     ENDIF
20592 * baryon-number/charge conservation check
20593       IF (IBTOT+IZTOT.NE.0) THEN
20594          WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
20595  1001    FORMAT(1X,'EVA2HE:   baryon-number/charge conservation ',
20596      &          'failure at event ',I8,' :  IBTOT,IZTOT = ',2I3)
20597       ENDIF
20598
20599       RETURN
20600       END
20601
20602 *$ CREATE DT_EBIND.FOR
20603 *COPY DT_EBIND
20604 *
20605 *===ebind==============================================================*
20606 *
20607       DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
20608
20609 ************************************************************************
20610 * Binding energy for nuclei.                                           *
20611 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972)                  *
20612 *                 IA        mass number                                *
20613 *                 IZ        atomic number                              *
20614 * This version dated 5.5.95   is updated by S. Roesler.                *
20615 ************************************************************************
20616
20617       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20618       SAVE
20619
20620       PARAMETER ( LINP = 10 ,
20621      &            LOUT = 6 ,
20622      &            LDAT = 9 )
20623
20624       PARAMETER (ZERO=0.0D0)
20625
20626       DATA       A1,       A2,        A3,        A4,      A5
20627      &     / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
20628
20629       IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
20630          WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0.  ',IA,IZ
20631          DT_EBIND = ZERO
20632          RETURN
20633       ENDIF
20634       AA = IA
20635       DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
20636      &        -A4*(IA-2*IZ)**2/AA
20637       IF (MOD(IA,2).EQ.1) THEN
20638          IA5 = 0
20639       ELSEIF (MOD(IZ,2).EQ.1) THEN
20640          IA5 = 1
20641       ELSE
20642          IA5 = -1
20643       ENDIF
20644       DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
20645
20646       RETURN
20647       END
20648
20649 ************************************************************************
20650 *                                                                      *
20651 *  DPMJET 3.0:   cross section routines                                *
20652 *                                                                      *
20653 ************************************************************************
20654 *
20655 *
20656 *     SUBROUTINE DT_SHNDIF
20657 *         diffractive cross sections (all energies)
20658 *     SUBROUTINE DT_PHOXS
20659 *         total and inel. cross sections from PHOJET interpol. tables
20660 *     SUBROUTINE DT_XSHN
20661 *         total and el. cross sections for all energies
20662 *     SUBROUTINE DT_SIHNAB
20663 *         pion 2-nucleon absorption cross sections
20664 *     SUBROUTINE DT_SIGEMU
20665 *         cross section for target "compounds"
20666 *     SUBROUTINE DT_SIGGA
20667 *         photon nucleus cross sections
20668 *     SUBROUTINE DT_SIGGAT
20669 *         photon nucleus cross sections from tables
20670 *     SUBROUTINE DT_SANO
20671 *         anomalous hard photon-nucleon cross sections from tables
20672 *     SUBROUTINE DT_SIGGP
20673 *         photon nucleon cross sections
20674 *     SUBROUTINE DT_SIGVEL
20675 *         quasi-elastic vector meson prod. cross sections
20676 *     DOUBLE PRECISION FUNCTION DT_SIGVP
20677 *         sigma_VN(tilde)
20678 *     DOUBLE PRECISION FUNCTION DT_RRM2
20679 *     DOUBLE PRECISION FUNCTION DT_RM2
20680 *     DOUBLE PRECISION FUNCTION DT_SAM2
20681 *     SUBROUTINE DT_CKMT
20682 *     SUBROUTINE DT_CKMTX
20683 *     SUBROUTINE DT_PDF0
20684 *     SUBROUTINE DT_CKMTQ0
20685 *     SUBROUTINE DT_CKMTDE
20686 *     SUBROUTINE DT_CKMTPR
20687 *     FUNCTION DT_CKMTFF
20688 *
20689 *     SUBROUTINE DT_FLUINI
20690 *         total nucleon cross section fluctuation treatment
20691 *
20692 *     SUBROUTINE DT_SIGTBL
20693 *         pre-tabulation of low-energy elastic x-sec. using SIHNEL
20694 *     SUBROUTINE DT_XSTABL
20695 *         service routines
20696 *
20697 *
20698 *$ CREATE DT_SHNDIF.FOR
20699 *COPY DT_SHNDIF
20700 *
20701 *===shndif===============================================================*
20702 *
20703       SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
20704
20705 **********************************************************************
20706 *   Single diffractive hadron-nucleon cross sections                 *
20707 *                                              S.Roesler 14/1/93     *
20708 *                                                                    *
20709 *   The cross sections are calculated from extrapolated single       *
20710 *   diffractive antiproton-proton cross sections (DTUJET92) using    *
20711 *   scaling relations between total and single diffractive cross     *
20712 *   sections.                                                        *
20713 **********************************************************************
20714
20715       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20716       SAVE
20717       PARAMETER (ZERO=0.0D0)
20718
20719 * particle properties (BAMJET index convention)
20720       CHARACTER*8  ANAME
20721       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20722      &                IICH(210),IIBAR(210),K1(210),K2(210)
20723 *
20724       CSD1   =   4.201483727D0
20725       CSD4   = -0.4763103556D-02
20726       CSD5   =  0.4324148297D0
20727 *
20728       CHMSD1 =  0.8519297242D0
20729       CHMSD4 = -0.1443076599D-01
20730       CHMSD5 =  0.4014954567D0
20731 *
20732       EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
20733       PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
20734 *
20735       SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20736       SHMSD  = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
20737       FRAC   = SHMSD/SDIAPP
20738 *
20739       GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
20740      &     999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
20741      &      10, 10, 20, 20, 20) KPROJ
20742 *
20743    10 CONTINUE
20744 *---------------------------- p - p , n - p , sigma0+- - p ,
20745 *                             Lambda - p
20746       CSD1   =  6.004476070D0
20747       CSD4   = -0.1257784606D-03
20748       CSD5   =  0.2447335720D0
20749       SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20750       SIGDIH = FRAC*SIGDIF
20751       RETURN
20752 *
20753    20 CONTINUE
20754 *
20755       KPSCAL = 2
20756       KTSCAL = 1
20757 C     F      = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
20758       DUMZER = ZERO
20759       CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
20760       F      = SDIAPP/SIGTO
20761       KT     = 1
20762 C     SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
20763       CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
20764       SIGDIF = SIGTO*F
20765       SIGDIH = FRAC*SIGDIF
20766       RETURN
20767 *
20768   999 CONTINUE
20769 *-------------------------- leptons..
20770       SIGDIF = 1.D-10
20771       SIGDIH = 1.D-10
20772       RETURN
20773       END
20774
20775 *$ CREATE DT_PHOXS.FOR
20776 *COPY DT_PHOXS
20777 *
20778 *===phoxs================================================================*
20779 *
20780       SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
20781
20782 ************************************************************************
20783 * Total/inelastic proton-nucleon cross sections taken from PHOJET-     *
20784 * interpolation tables.                                                *
20785 * This version dated 05.11.97 is written by S. Roesler                 *
20786 ************************************************************************
20787
20788       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20789       SAVE
20790
20791       PARAMETER ( LINP = 10 ,
20792      &            LOUT = 6 ,
20793      &            LDAT = 9 )
20794
20795       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20796       PARAMETER (TWOPI  = 6.283185307179586454D+00,
20797      &           PI     = TWOPI/TWO,
20798      &           GEV2MB = 0.38938D0)
20799
20800       LOGICAL LFIRST
20801       DATA LFIRST /.TRUE./
20802
20803 * nucleon-nucleon event-generator
20804       CHARACTER*8 CMODEL
20805       LOGICAL LPHOIN
20806       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20807
20808 * particle properties (BAMJET index convention)
20809       CHARACTER*8  ANAME
20810       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20811      &                IICH(210),IIBAR(210),K1(210),K2(210)
20812
20813 **PHOJET105a
20814 C     PARAMETER (IEETAB=10)
20815 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20816 **PHOJET110
20817
20818 C  energy-interpolation table
20819       INTEGER IEETA2
20820       PARAMETER ( IEETA2 = 20 )
20821       INTEGER ISIMAX
20822       DOUBLE PRECISION SIGTAB,SIGECM
20823       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20824 **
20825
20826       IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
20827          WRITE(LOUT,*) MCGENE
20828  1000    FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
20829          STOP
20830       ENDIF
20831
20832       IF (ECM.LE.ZERO) THEN
20833          EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
20834          ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
20835       ENDIF
20836
20837       IF (MODE.EQ.1) THEN
20838 * DL
20839          DELDL = 0.0808D0
20840          EPSDL = -0.4525D0
20841          S     = ECM*ECM
20842          STOT  = 21.7D0*S**DELDL+56.08D0*S**EPSDL
20843          ALPHAP= 0.25D0
20844          BEL   = 8.5D0+2.D0*ALPHAP*LOG(S)
20845          SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
20846          SINE  = STOT-SIGEL
20847          SDIF1 = ZERO
20848       ELSE
20849 * Phojet
20850          IP = 1
20851          IF(ECM.LE.SIGECM(IP,1)) THEN
20852            I1 = 1
20853            I2 = 1
20854          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
20855            DO 1 I=2,ISIMAX
20856               IF (ECM.LE.SIGECM(IP,I)) GOTO 2
20857     1      CONTINUE
20858     2      CONTINUE
20859            I1 = I-1
20860            I2 = I
20861          ELSE
20862            IF (LFIRST) THEN
20863               WRITE(LOUT,'(/1X,A,2E12.3)')
20864      &          'PHOXS: warning! energy above initialization limit (',
20865      &          ECM,SIGECM(IP,ISIMAX)
20866              LFIRST = .FALSE.
20867            ENDIF
20868            I1 = ISIMAX
20869            I2 = ISIMAX
20870          ENDIF
20871          FAC2 = ZERO
20872          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
20873      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
20874          FAC1  = ONE-FAC2
20875          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
20876          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
20877          SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
20878      &           FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
20879          BEL   = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
20880       ENDIF
20881
20882       RETURN
20883       END
20884
20885 *$ CREATE DT_XSHN.FOR
20886 *COPY DT_XSHN
20887 *
20888 *===xshn===============================================================*
20889 *
20890       SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
20891
20892 ************************************************************************
20893 * Total and elastic hadron-nucleon cross section.                      *
20894 * Below 500GeV cross sections are based on the '98 data compilation    *
20895 * of the PDG. At higher energies PHOJET results are used (patched to   *
20896 * the low energy data at 500GeV).                                      *
20897 *     IP      projectile index (BAMJET numbering scheme)               *
20898 *             (should be in the range 1..25)                           *
20899 *     IT      target index (BAMJET numbering scheme)                   *
20900 *             (1 = proton, 8 = neutron)                                *
20901 *     PL      laboratory momentum                                      *
20902 *     ECM     cm. energy (ignored if PL>0)                             *
20903 *     STOT    total cross section                                      *
20904 *     SELA    elastic cross section                                    *
20905 * Last change: 24.4.99 by S. Roesler                                   *
20906 ************************************************************************
20907
20908       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20909       SAVE
20910
20911       PARAMETER ( LINP = 10 ,
20912      &            LOUT = 6 ,
20913      &            LDAT = 9 )
20914
20915       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
20916
20917       PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
20918      &           PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
20919       PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
20920
20921       LOGICAL LFIRST
20922
20923 * particle properties (BAMJET index convention)
20924       CHARACTER*8  ANAME
20925       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20926      &                IICH(210),IIBAR(210),K1(210),K2(210)
20927
20928 * nucleon-nucleon event-generator
20929       CHARACTER*8 CMODEL
20930       LOGICAL LPHOIN
20931       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20932 **PHOJET105a
20933 C     PARAMETER (IEETAB=10)
20934 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20935 **PHOJET110
20936
20937 C  energy-interpolation table
20938       INTEGER IEETA2
20939       PARAMETER ( IEETA2 = 20 )
20940       INTEGER ISIMAX
20941       DOUBLE PRECISION SIGTAB,SIGECM
20942       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20943
20944       DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
20945       DIMENSION IDXDAT(25,2)
20946 *
20947       DATA APL /
20948      &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
20949      &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
20950      &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
20951      &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
20952      & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
20953      & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
20954      & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
20955 *
20956 * total cross sections:
20957 * p p
20958       DATA (ASIGTO(1,K),K=1,NPOINT) /
20959      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
20960      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
20961      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
20962      & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
20963      & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
20964      & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
20965      & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
20966 * pbar p
20967       DATA (ASIGTO(2,K),K=1,NPOINT) /
20968      & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
20969      & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
20970      & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
20971      & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
20972      & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
20973      & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
20974      & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
20975 * n p
20976       DATA (ASIGTO(3,K),K=1,NPOINT) /
20977      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
20978      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
20979      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
20980      & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
20981      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
20982      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
20983      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
20984 * pi+ p
20985       DATA (ASIGTO(4,K),K=1,NPOINT) /
20986      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
20987      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
20988      & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
20989      & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
20990      & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
20991      & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
20992      & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
20993 * pi- p
20994       DATA (ASIGTO(5,K),K=1,NPOINT) /
20995      & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
20996      & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
20997      & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
20998      & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
20999      & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
21000      & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
21001      & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
21002 * K+ p
21003       DATA (ASIGTO(6,K),K=1,NPOINT) /
21004      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21005      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21006      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21007      & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21008      & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21009      & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21010      & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21011 * K- p
21012       DATA (ASIGTO(7,K),K=1,NPOINT) /
21013      & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21014      & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21015      & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21016      & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21017      & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21018      & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21019      & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21020 * K+ n
21021       DATA (ASIGTO(8,K),K=1,NPOINT) /
21022      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21023      & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21024      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21025      & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21026      & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21027      & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21028      & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21029 * K- n
21030       DATA (ASIGTO(9,K),K=1,NPOINT) /
21031      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21032      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21033      & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21034      & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21035      & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21036      & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21037      & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21038 * Lambda p
21039       DATA (ASIGTO(10,K),K=1,NPOINT) /
21040      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21041      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21042      & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21043      & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21044      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21045      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21046      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21047 *
21048 * elastic cross sections:
21049 * p p
21050       DATA (ASIGEL(1,K),K=1,NPOINT) /
21051      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21052      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21053      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21054      & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21055      & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21056      & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21057      & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21058 * pbar p
21059       DATA (ASIGEL(2,K),K=1,NPOINT) /
21060      & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21061      & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21062      & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21063      & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21064      & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21065      & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21066      & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21067 * n p
21068       DATA (ASIGEL(3,K),K=1,NPOINT) /
21069      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21070      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21071      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21072      & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21073      & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21074      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21075      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21076 * pi+ p
21077       DATA (ASIGEL(4,K),K=1,NPOINT) /
21078      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21079      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21080      & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21081      & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21082      & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21083      & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21084      & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21085 * pi- p
21086       DATA (ASIGEL(5,K),K=1,NPOINT) /
21087      & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21088      & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21089      & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21090      & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21091      & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21092      & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21093      & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21094 * K+ p
21095       DATA (ASIGEL(6,K),K=1,NPOINT) /
21096      & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21097      & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21098      & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21099      & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21100      & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21101      & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21102      & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21103 * K- p
21104       DATA (ASIGEL(7,K),K=1,NPOINT) /
21105      & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21106      & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21107      & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21108      & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21109      & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21110      & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21111      & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21112 * K+ n
21113       DATA (ASIGEL(8,K),K=1,NPOINT) /
21114      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21115      & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21116      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21117      & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21118      & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21119      & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21120      & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21121 * K- n
21122       DATA (ASIGEL(9,K),K=1,NPOINT) /
21123      & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21124      & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21125      & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21126      & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21127      & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21128      & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21129      & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21130 * Lambda p
21131       DATA (ASIGEL(10,K),K=1,NPOINT) /
21132      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21133      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21134      & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21135      & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21136      & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21137      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21138      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21139
21140       DATA (IDXDAT(K,1),K=1,25) /
21141      &  1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21142      &  1, 3,45, 8, 9/
21143       DATA (IDXDAT(K,2),K=1,25) /
21144      &  3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21145      &  3, 1,45, 6, 7/
21146
21147       DATA LFIRST /.TRUE./
21148
21149       IF (LFIRST) THEN
21150          APLABL = LOG10(PLABLO)
21151          APLABH = LOG10(PLABHI)
21152          APTHRE = LOG10(PTHRE)
21153          ADP1   = (APTHRE-APLABL)/DBLE(NPOIN1)
21154          ADP2   = (APLABH-APTHRE)/DBLE(NPOIN2)
21155          DUM0   = ZERO
21156          PHOPLA = PLABHI
21157          PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21158          ECMS   = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21159          IF (MCGENE.EQ.2) THEN
21160             IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21161                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21162             ELSE
21163                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21164             ENDIF
21165          ELSE
21166             CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21167          ENDIF
21168          PHOSEL = PHOSTO-PHOSIN
21169          APHOST = LOG10(PHOSTO)
21170          APHOSE = LOG10(PHOSEL)
21171          LFIRST = .FALSE.
21172       ENDIF
21173       STOT = ZERO
21174       SELA = ZERO
21175       PLAB = PL
21176       ECMS = ECM
21177       IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21178          WRITE(LOUT,1000) IP,IT
21179  1000    FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21180      &          'proj/target',2I4)
21181          STOP
21182       ENDIF
21183
21184       IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21185          ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21186          PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21187       ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21188          WRITE(LOUT,1001) PLAB,ECMS
21189  1001    FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21190          STOP
21191       ENDIF
21192
21193 * index of spectrum
21194       IDXP = IP
21195       IF (IP.GT.25) THEN
21196          IF (AAM(IP).GT.ZERO) THEN
21197             IF (ABS(IIBAR(IP)).GT.0) THEN
21198                IDXP = 1
21199             ELSE
21200                IDXP = 13
21201             ENDIF
21202          ELSE
21203             IDXP = 7
21204          ENDIF
21205       ENDIF
21206       IDXT = 1
21207       IF (IT.EQ.8) IDXT = 2
21208       IDXS = IDXDAT(IDXP,IDXT)
21209       IF (IDXS.EQ.0) RETURN
21210
21211 * compute momentum bin indices
21212       IF (PLAB.LT.PLABLO) THEN
21213          IDX0 = 1
21214          IDX1 = 1
21215       ELSEIF (PLAB.GE.PLABHI) THEN
21216          IDX0 = NPOINT
21217          IDX1 = NPOINT
21218       ELSE
21219          APLAB = LOG10(PLAB)
21220          IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21221             IDX0 = INT((APLAB-APLABL)/ADP1)+1
21222          ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21223             IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21224          ENDIF
21225          IDX1 = IDX0+1
21226       ENDIF
21227
21228 * interpolate cross section
21229       IF (IDXS.GT.10) THEN
21230          IDXS1 = IDXS/10
21231          IDXS2 = IDXS-10*IDXS1
21232          IF (IDX0.EQ.IDX1) THEN
21233             IF (IDX0.EQ.1) THEN
21234                ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21235                ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21236             ELSE
21237                DUM0   = ZERO
21238                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21239                PHOSEL = PHOSTO-PHOSIN
21240                ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21241                ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21242                ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21243                ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21244                ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21245                ASELA  = 0.5D0*(ASELA1+ASELA2)
21246             ENDIF
21247          ELSE
21248             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21249             ASTOT1 = ASIGTO(IDXS1,IDX0)+
21250      &               FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21251             ASTOT2 = ASIGTO(IDXS2,IDX0)+
21252      &               FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21253             ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21254             ASELA1 = ASIGEL(IDXS1,IDX0)+
21255      &               FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21256             ASELA2 = ASIGEL(IDXS2,IDX0)+
21257      &               FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21258             ASELA  = 0.5D0*(ASELA1+ASELA2)
21259          ENDIF
21260       ELSE
21261          IF (IDX0.EQ.IDX1) THEN
21262             IF (IDX0.EQ.1) THEN
21263                ASTOT = ASIGTO(IDXS,IDX0)
21264                ASELA = ASIGEL(IDXS,IDX0)
21265             ELSE
21266                DUM0   = ZERO
21267                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21268                PHOSEL = PHOSTO-PHOSIN
21269                ASTOT  = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21270                ASELA  = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21271             ENDIF
21272          ELSE
21273             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21274             ASTOT = ASIGTO(IDXS,IDX0)+
21275      &              FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21276             ASELA = ASIGEL(IDXS,IDX0)+
21277      &              FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21278          ENDIF
21279       ENDIF
21280       STOT = 10.0D0**ASTOT
21281       SELA = 10.0D0**ASELA
21282
21283       RETURN
21284       END
21285
21286 *$ CREATE DT_SIHNAB.FOR
21287 *COPY DT_SIHNAB
21288 *
21289 *===sihnab===============================================================*
21290 *
21291       SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21292
21293 **********************************************************************
21294 * Pion 2-nucleon absorption cross sections.                          *
21295 * (sigma_tot for pi+ d --> p p, pi- d --> n n                        *
21296 *  taken from Ritchie PRC 28 (1983) 926 )                            *
21297 * This version dated 18.05.96 is written by S. Roesler               *
21298 **********************************************************************
21299
21300       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21301       SAVE
21302       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21303       PARAMETER (AMPR = 938.0D0,
21304      &           AMPI = 140.0D0,
21305      &           AMDE = TWO*AMPR,
21306      &           A    = -1.2D0,
21307      &           B    = 3.5D0,
21308      &           C    = 7.4D0,
21309      &           D    = 5600.0D0,
21310      &           ER   = 2136.0D0)
21311
21312       SIGABS = ZERO
21313       IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21314      &                   .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21315       PTOT = PLAB*1.0D3
21316       EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21317       IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21318       ECM  = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21319       SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21320 * approximate 3N-abs., I=1-abs. etc.
21321       SIGABS = SIGABS/0.40D0
21322 * pi0-absorption (rough approximation!!)
21323       IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21324
21325       RETURN
21326       END
21327
21328 *$ CREATE DT_SIGEMU.FOR
21329 *COPY DT_SIGEMU
21330 *
21331 *===sigemu=============================================================*
21332 *
21333       SUBROUTINE DT_SIGEMU
21334
21335 ************************************************************************
21336 * Combined cross section for target compounds.                         *
21337 * This version dated 6.4.98   is written by S. Roesler                 *
21338 ************************************************************************
21339
21340       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21341       SAVE
21342
21343       PARAMETER ( LINP = 10 ,
21344      &            LOUT = 6 ,
21345      &            LDAT = 9 )
21346
21347       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21348      &           OHALF=0.5D0,ONE=1.0D0)
21349
21350       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21351
21352 * Glauber formalism: cross sections
21353       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21354      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21355      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21356      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21357      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21358      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21359      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21360      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21361      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21362      &                BSLOPE,NEBINI,NQBINI
21363
21364 * emulsion treatment
21365       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21366      &                NCOMPO,IEMUL
21367
21368 * nucleon-nucleon event-generator
21369       CHARACTER*8 CMODEL
21370       LOGICAL LPHOIN
21371       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21372
21373       IF (MCGENE.NE.4) THEN
21374          WRITE(LOUT,'(A)') ' DT_SIGEMU:    Combined cross sections'
21375          WRITE(LOUT,'(15X,A)') '-----------------------'
21376       ENDIF
21377       DO 1 IE=1,NEBINI
21378          DO 2 IQ=1,NQBINI
21379             SIGTOT = ZERO
21380             SIGELA = ZERO
21381             SIGQEP = ZERO
21382             SIGQET = ZERO
21383             SIGQE2 = ZERO
21384             SIGPRO = ZERO
21385             SIGDEL = ZERO
21386             SIGDQE = ZERO
21387             ERRTOT = ZERO
21388             ERRELA = ZERO
21389             ERRQEP = ZERO
21390             ERRQET = ZERO
21391             ERRQE2 = ZERO
21392             ERRPRO = ZERO
21393             ERRDEL = ZERO
21394             ERRDQE = ZERO
21395             IF (NCOMPO.GT.0) THEN
21396                DO 3 IC=1,NCOMPO
21397                   SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21398                   SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21399                   SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21400                   SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21401                   SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21402                   SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21403                   SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21404                   SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21405                   ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21406                   ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21407                   ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21408                   ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21409                   ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21410                   ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21411                   ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21412                   ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21413     3          CONTINUE
21414                ERRTOT = SQRT(ERRTOT)
21415                ERRELA = SQRT(ERRELA)
21416                ERRQEP = SQRT(ERRQEP)
21417                ERRQET = SQRT(ERRQET)
21418                ERRQE2 = SQRT(ERRQE2)
21419                ERRPRO = SQRT(ERRPRO)
21420                ERRDEL = SQRT(ERRDEL)
21421                ERRDQE = SQRT(ERRDQE)
21422             ELSE
21423                SIGTOT = XSTOT(IE,IQ,1)
21424                SIGELA = XSELA(IE,IQ,1)
21425                SIGQEP = XSQEP(IE,IQ,1)
21426                SIGQET = XSQET(IE,IQ,1)
21427                SIGQE2 = XSQE2(IE,IQ,1)
21428                SIGPRO = XSPRO(IE,IQ,1)
21429                SIGDEL = XSDEL(IE,IQ,1)
21430                SIGDQE = XSDQE(IE,IQ,1)
21431                ERRTOT = XETOT(IE,IQ,1)
21432                ERRELA = XEELA(IE,IQ,1)
21433                ERRQEP = XEQEP(IE,IQ,1)
21434                ERRQET = XEQET(IE,IQ,1)
21435                ERRQE2 = XEQE2(IE,IQ,1)
21436                ERRPRO = XEPRO(IE,IQ,1)
21437                ERRDEL = XEDEL(IE,IQ,1)
21438                ERRDQE = XEDQE(IE,IQ,1)
21439             ENDIF
21440             IF (MCGENE.NE.4) THEN
21441                WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21442  1000         FORMAT(/,1X,'E_cm =',F9.1,' GeV  Q^2 =',F6.1,' GeV^2 :',/)
21443                WRITE(LOUT,1001) SIGTOT,ERRTOT
21444  1001          FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21445                WRITE(LOUT,1002) SIGELA,ERRELA
21446  1002          FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21447                WRITE(LOUT,1003) SIGQEP,ERRQEP
21448  1003          FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21449      &                F11.5,' mb')
21450                WRITE(LOUT,1004) SIGQET,ERRQET
21451  1004          FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21452      &                F11.5,' mb')
21453                WRITE(LOUT,1005) SIGQE2,ERRQE2
21454  1005          FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21455      &                ' +-',F11.5,' mb')
21456                WRITE(LOUT,1006) SIGPRO,ERRPRO
21457  1006          FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21458                WRITE(LOUT,1007) SIGDEL,ERRDEL
21459  1007          FORMAT(1X,'diff-el   ',27X,F10.4,' +-',F11.5,' mb')
21460                WRITE(LOUT,1008) SIGDQE,ERRDQE
21461  1008          FORMAT(1X,'diff-qel  ',27X,F10.4,' +-',F11.5,' mb')
21462             ENDIF
21463
21464     2    CONTINUE
21465     1 CONTINUE
21466
21467       RETURN
21468       END
21469
21470 *$ CREATE DT_SIGGA.FOR
21471 *COPY DT_SIGGA
21472 *
21473 *===sigga==============================================================*
21474 *
21475       SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21476
21477 ************************************************************************
21478 * Total/inelastic photon-nucleus cross sections.                       *
21479 *     !!!! Overwrites SHMAKI-initialization. Do not use it during      *
21480 *          production runs !!!!                                        *
21481 * This version dated 27.03.96 is written by S. Roesler                 *
21482 ************************************************************************
21483
21484       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21485       SAVE
21486
21487       PARAMETER ( LINP = 10 ,
21488      &            LOUT = 6 ,
21489      &            LDAT = 9 )
21490
21491       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21492      &           OHALF=0.5D0,ONE=1.0D0)
21493       PARAMETER (AMPROT = 0.938D0)
21494
21495       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21496
21497 * Glauber formalism: cross sections
21498       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21499      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21500      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21501      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21502      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21503      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21504      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21505      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21506      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21507      &                BSLOPE,NEBINI,NQBINI
21508
21509       NT  = NTI
21510       X   = XI
21511       Q2  = Q2I
21512       ECM = ECMI
21513       XNU = XNUI
21514       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21515      &   ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21516       CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21517       STOT  = XSTOT(1,1,1)
21518       ETOT  = XETOT(1,1,1)
21519       SIN   = XSPRO(1,1,1)
21520       EIN   = XEPRO(1,1,1)
21521
21522       RETURN
21523       END
21524
21525 *$ CREATE DT_SIGGAT.FOR
21526 *COPY DT_SIGGAT
21527 *
21528 *===siggat=============================================================*
21529 *
21530       SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21531
21532 ************************************************************************
21533 * Total/inelastic photon-nucleus cross sections.                       *
21534 * Uses pre-tabulated cross section.                                    *
21535 * This version dated 29.07.96 is written by S. Roesler                 *
21536 ************************************************************************
21537
21538       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21539       SAVE
21540
21541       PARAMETER ( LINP = 10 ,
21542      &            LOUT = 6 ,
21543      &            LDAT = 9 )
21544
21545       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21546      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21547
21548       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21549
21550 * Glauber formalism: cross sections
21551       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21552      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21553      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21554      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21555      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21556      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21557      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21558      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21559      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21560      &                BSLOPE,NEBINI,NQBINI
21561
21562       NTARG = ABS(NT)
21563       I1   = 1
21564       I2   = 1
21565       RATE = ONE
21566       IF (NEBINI.GT.1) THEN
21567          IF (ECMI.GE.ECMNN(NEBINI)) THEN
21568             I1   = NEBINI
21569             I2   = NEBINI
21570             RATE = ONE
21571          ELSEIF (ECMI.GT.ECMNN(1)) THEN
21572             DO 1 I=2,NEBINI
21573                IF (ECMI.LT.ECMNN(I)) THEN
21574                   I1   = I-1
21575                   I2   = I
21576                   RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21577                   GOTO 2
21578                ENDIF
21579     1       CONTINUE
21580     2       CONTINUE
21581          ENDIF
21582       ENDIF
21583       J1   = 1
21584       J2   = 1
21585       RATQ = ONE
21586       IF (NQBINI.GT.1) THEN
21587          IF (Q2I.GE.Q2G(NQBINI)) THEN
21588             J1   = NQBINI
21589             J2   = NQBINI
21590             RATQ = ONE
21591          ELSEIF (Q2I.GT.Q2G(1)) THEN
21592             DO 3 I=2,NQBINI
21593                IF (Q2I.LT.Q2G(I)) THEN
21594                   J1   = I-1
21595                   J2   = I
21596                   RATQ = LOG10(    Q2I/MAX(Q2G(J1),TINY14))/
21597      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21598 C                 RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21599                   GOTO 4
21600                ENDIF
21601     3       CONTINUE
21602     4       CONTINUE
21603          ENDIF
21604       ENDIF
21605
21606       STOT = XSTOT(I1,J1,NTARG)+
21607      &   RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21608      &   RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21609      &   RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21610      &              XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21611
21612       RETURN
21613       END
21614
21615 *$ CREATE DT_SANO.FOR
21616 *COPY DT_SANO
21617 *
21618 *===sigano=============================================================*
21619 *
21620       DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21621
21622 ************************************************************************
21623 * This version dated 31.07.96 is written by S. Roesler                 *
21624 ************************************************************************
21625
21626       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21627       SAVE
21628
21629       PARAMETER ( LINP = 10 ,
21630      &            LOUT = 6 ,
21631      &            LDAT = 9 )
21632
21633       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21634      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21635       PARAMETER (NE = 8)
21636
21637 * VDM parameter for photon-nucleus interactions
21638       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21639
21640 * properties of interacting particles
21641       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
21642
21643       DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
21644       DATA ECMANO /
21645      &             0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
21646      &             0.100D+04,0.200D+04,0.500D+04
21647      &            /
21648 * fixed cut (3 GeV/c)
21649       DATA FRAANO /
21650      &             0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
21651      &             0.062D+00,0.054D+00,0.042D+00
21652      &            /
21653       DATA SIGHRD /
21654      &           4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
21655      &           3.3086D-01,7.6255D-01,2.1319D+00
21656      &            /
21657 * running cut (based on obsolete Phojet-caluclations, bugs..)
21658 C     DATA FRAANO /
21659 C    &             0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
21660 C    &             0.167E+00,0.150E+00,0.131E+00
21661 C    &            /
21662 C     DATA SIGHRD /
21663 C    &           6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
21664 C    &           2.5736E-01,4.5593E-01,8.2550E-01
21665 C    &            /
21666
21667       DT_SANO = ZERO
21668       IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
21669       J1   = 0
21670       J2   = 0
21671       RATE = ONE
21672       IF (ECM.GE.ECMANO(NE)) THEN
21673          J1 = NE
21674          J2 = NE
21675       ELSEIF (ECM.GT.ECMANO(1)) THEN
21676          DO 1 IE=2,NE
21677             IF (ECM.LT.ECMANO(IE)) THEN
21678                J1   = IE-1
21679                J2   = IE
21680                RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
21681                GOTO 2
21682             ENDIF
21683     1    CONTINUE
21684     2    CONTINUE
21685       ENDIF
21686       IF ((J1.GT.0).AND.(J2.GT.0)) THEN
21687          AFRA1  = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
21688          AFRA2  = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
21689          DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
21690       ENDIF
21691
21692       RETURN
21693       END
21694
21695 *$ CREATE DT_SIGGP.FOR
21696 *COPY DT_SIGGP
21697 *
21698 *===siggp==============================================================*
21699 *
21700       SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
21701
21702 ************************************************************************
21703 * Total/inelastic photon-nucleon cross sections.                       *
21704 * This version dated 30.04.96 is written by S. Roesler                 *
21705 ************************************************************************
21706
21707       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21708       SAVE
21709
21710       PARAMETER ( LINP = 10 ,
21711      &            LOUT = 6 ,
21712      &            LDAT = 9 )
21713
21714       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21715       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
21716      &           PI     = TWOPI/TWO,
21717      &           GEV2MB = 0.38938D0,
21718      &           ALPHEM = ONE/137.0D0)
21719
21720 * particle properties (BAMJET index convention)
21721       CHARACTER*8  ANAME
21722       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21723      &                IICH(210),IIBAR(210),K1(210),K2(210)
21724
21725 * VDM parameter for photon-nucleus interactions
21726       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21727
21728 **PHOJET105a
21729 C     CHARACTER*8 MDLNA
21730 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
21731 C     PARAMETER (IEETAB=10)
21732 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21733 **PHOJET110
21734
21735 C  model switches and parameters
21736       CHARACTER*8 MDLNA
21737       INTEGER ISWMDL,IPAMDL
21738       DOUBLE PRECISION PARMDL
21739       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21740
21741 C  energy-interpolation table
21742       INTEGER IEETA2
21743       PARAMETER ( IEETA2 = 20 )
21744       INTEGER ISIMAX
21745       DOUBLE PRECISION SIGTAB,SIGECM
21746       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21747 **
21748
21749 C     PARAMETER (NPOINT=80)
21750       PARAMETER (NPOINT=16)
21751       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
21752
21753       STOT = ZERO
21754       SINE = ZERO
21755       SDIR = ZERO
21756
21757       W2 = ECMI**2
21758       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21759      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21760       Q2 = Q2I
21761       X  = XI
21762 * photoprod.
21763       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21764          Q2 = 0.0001D0
21765          X  = Q2/(W2+Q2-AAM(1)**2)
21766 * DIS
21767       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21768          X  = Q2/(W2+Q2-AAM(1)**2)
21769       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21770          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21771       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21772          W2 = Q2*(ONE-X)/X+AAM(1)**2
21773       ELSE
21774          WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
21775          STOP
21776       ENDIF
21777       ECM = SQRT(W2)
21778
21779       IF (MODEGA.EQ.1) THEN
21780          SCALE = SQRT(Q2)
21781          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21782      &                                                       IDPDF)
21783 C        W = SQRT(W2)
21784
21785 C        ALLMF2 = PHO_ALLM97(Q2,W)
21786
21787 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
21788          STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
21789          SINE = ZERO
21790          SDIR = ZERO
21791       ELSEIF (MODEGA.EQ.2) THEN
21792          IF (INTRGE(1).EQ.1) THEN
21793             AMLO2 = (3.0D0*AAM(13))**2
21794          ELSEIF (INTRGE(1).EQ.2) THEN
21795             AMLO2 = AAM(33)**2
21796          ELSE
21797             AMLO2 = AAM(96)**2
21798          ENDIF
21799          IF (INTRGE(2).EQ.1) THEN
21800             AMHI2 = W2/TWO
21801          ELSEIF (INTRGE(2).EQ.2) THEN
21802             AMHI2 = W2/4.0D0
21803          ELSE
21804             AMHI2 = W2
21805          ENDIF
21806          AMHI20 = (ECM-AAM(1))**2
21807          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
21808          XAMLO  = LOG( AMLO2+Q2 )
21809          XAMHI  = LOG( AMHI2+Q2 )
21810 **PHOJET105a
21811 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21812 **PHOJET112
21813
21814          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21815
21816 **
21817          SUM  = ZERO
21818          DO 1 J=1,NPOINT
21819             AM2 = EXP(ABSZX(J))-Q2
21820             IF (AM2.LT.16.0D0) THEN
21821                R = TWO
21822             ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
21823                R = 10.0D0/3.0D0
21824             ELSE
21825                R = 11.0D0/3.0D0
21826             ENDIF
21827 C           FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21828             FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21829      &            * (ONE+EPSPOL*Q2/AM2)
21830             SUM = SUM+WEIGHT(J)*FAC
21831     1    CONTINUE
21832          SINE = SUM
21833          SDIR = DT_SIGVP(X,Q2)
21834          STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
21835          SDIR = SDIR/(0.588D0+RL2+Q2)
21836 C        STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
21837       ELSEIF (MODEGA.EQ.3) THEN
21838          CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
21839       ELSEIF (MODEGA.EQ.4) THEN
21840 *  load cross sections from PHOJET interpolation table
21841          IP = 1
21842          IF(ECM.LE.SIGECM(IP,1)) THEN
21843            I1 = 1
21844            I2 = 1
21845          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21846            DO 2 I=2,ISIMAX
21847               IF (ECM.LE.SIGECM(IP,I)) GOTO 3
21848     2      CONTINUE
21849     3      CONTINUE
21850            I1 = I-1
21851            I2 = I
21852          ELSE
21853            WRITE(LOUT,'(/1X,A,2E12.3)')
21854      &       'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
21855            I1 = ISIMAX
21856            I2 = ISIMAX
21857          ENDIF
21858          FAC2 = ZERO
21859          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21860      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21861          FAC1 = ONE-FAC2
21862 *  cross section dependence on photon virtuality
21863          FSUP1 = ZERO
21864          DO 4 I=1,3
21865             FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
21866      &                                /(1.D0+Q2/PARMDL(30+I))**2
21867     4    CONTINUE
21868          FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
21869          FAC1  = FAC1*FSUP1
21870          FAC2  = FAC2*FSUP1
21871          FSUP2 = 1.0D0
21872          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21873          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21874          SDIR  = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
21875 **re:
21876          STOT  = STOT-SDIR
21877 **
21878          SDIR  = SDIR/(FSUP1*FSUP2)
21879 **re:
21880          STOT  = STOT+SDIR
21881 **
21882       ENDIF
21883
21884       RETURN
21885       END
21886
21887 *$ CREATE DT_SIGVEL.FOR
21888 *COPY DT_SIGVEL
21889 *
21890 *===sigvel=============================================================*
21891 *
21892       SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
21893
21894 ************************************************************************
21895 * Cross section for elastic vector meson production                    *
21896 * This version dated 10.05.96 is written by S. Roesler                 *
21897 ************************************************************************
21898
21899       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21900       SAVE
21901
21902       PARAMETER ( LINP = 10 ,
21903      &            LOUT = 6 ,
21904      &            LDAT = 9 )
21905
21906       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21907       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
21908      &           PI     = TWOPI/TWO,
21909      &           GEV2MB = 0.38938D0,
21910      &           ALPHEM = ONE/137.0D0)
21911
21912 * particle properties (BAMJET index convention)
21913       CHARACTER*8  ANAME
21914       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21915      &                IICH(210),IIBAR(210),K1(210),K2(210)
21916
21917 * VDM parameter for photon-nucleus interactions
21918       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21919
21920       W2 = ECMI**2
21921       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21922      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21923       Q2 = Q2I
21924       X  = XI
21925 * photoprod.
21926       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21927          Q2 = 0.0001D0
21928          X  = Q2/(W2+Q2-AAM(1)**2)
21929 * DIS
21930       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21931          X  = Q2/(W2+Q2-AAM(1)**2)
21932       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21933          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21934       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21935          W2 = Q2*(ONE-X)/X+AAM(1)**2
21936       ELSE
21937          WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
21938          STOP
21939       ENDIF
21940       ECM = SQRT(W2)
21941
21942       AMV  = AAM(IDXV)
21943       AMV2 = AMV**2
21944
21945       BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
21946      &        +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
21947       ROSH   = 0.1D0
21948       STOVP  = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
21949       SELVP  = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
21950
21951       IF (IDXV.EQ.33) THEN
21952          COUPL = 0.00365D0
21953       ELSE
21954          STOP
21955       ENDIF
21956       SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
21957       SIG2 = SELVP
21958       SVEL  = COUPL * (AMV2/(AMV2+Q2))**2
21959      &              * (ONE+EPSPOL*Q2/AMV2) * SELVP
21960
21961       RETURN
21962       END
21963
21964 *$ CREATE DT_SIGVP.FOR
21965 *COPY DT_SIGVP
21966 *
21967 *===sigvp==============================================================*
21968 *
21969       DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
21970
21971 ************************************************************************
21972 * sigma_Vp                                                             *
21973 ************************************************************************
21974
21975       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21976       SAVE
21977
21978       PARAMETER ( LINP = 10 ,
21979      &            LOUT = 6 ,
21980      &            LDAT = 9 )
21981
21982       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21983       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21984      &           PI    = TWOPI/TWO,
21985      &           GEV2MB = 0.38938D0,
21986      &           AMPROT = 0.938D0,
21987      &           ALPHEM = ONE/137.0D0)
21988
21989 * VDM parameter for photon-nucleus interactions
21990       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21991
21992       X  = XI
21993       Q2 = Q2I
21994       IF (XI.LE.ZERO)  X  = 0.0001D0
21995       IF (Q2I.LE.ZERO) Q2 = 0.0001D0
21996
21997       ECM    = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
21998
21999       SCALE = SQRT(Q2)
22000       IF (MODEGA.EQ.1) THEN
22001          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
22002      &                                                       IDPDF)
22003 C        W = ECM
22004
22005 C        ALLMF2 = PHO_ALLM97(Q2,W)
22006
22007 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22008 C        STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22009 C        DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22010          DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22011       ELSEIF (MODEGA.EQ.4) THEN
22012          CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22013 C        F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22014          DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22015       ELSE
22016          STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22017       ENDIF
22018
22019       RETURN
22020
22021       END
22022
22023 *$ CREATE DT_RRM2.FOR
22024 *COPY DT_RRM2
22025 *
22026 *===RRM2===============================================================*
22027 *
22028       DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22029
22030       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22031       SAVE
22032
22033       PARAMETER ( LINP = 10 ,
22034      &            LOUT = 6 ,
22035      &            LDAT = 9 )
22036
22037       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22038       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22039      &           PI    = TWOPI/TWO,
22040      &           GEV2MB = 0.38938D0)
22041
22042 * particle properties (BAMJET index convention)
22043       CHARACTER*8  ANAME
22044       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22045      &                IICH(210),IIBAR(210),K1(210),K2(210)
22046
22047 * VDM parameter for photon-nucleus interactions
22048       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22049
22050       S   = Q2*(ONE-X)/X+AAM(1)**2
22051       ECM = SQRT(S)
22052
22053       IF (INTRGE(1).EQ.1) THEN
22054          AMLO2 = (3.0D0*AAM(13))**2
22055       ELSEIF (INTRGE(1).EQ.2) THEN
22056          AMLO2 = AAM(33)**2
22057       ELSE
22058          AMLO2 = AAM(96)**2
22059       ENDIF
22060       IF (INTRGE(2).EQ.1) THEN
22061          AMHI2 = S/TWO
22062       ELSEIF (INTRGE(2).EQ.2) THEN
22063          AMHI2 = S/4.0D0
22064       ELSE
22065          AMHI2 = S
22066       ENDIF
22067       AMHI20 = (ECM-AAM(1))**2
22068       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22069
22070       AM1C2 = 16.0D0
22071       AM2C2 = 121.0D0
22072       IF (AMHI2.LE.AM1C2) THEN
22073          DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22074       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22075          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22076      &          10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22077       ELSE
22078          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22079      &          10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22080      &          11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22081       ENDIF
22082
22083       RETURN
22084       END
22085
22086 *$ CREATE DT_RM2.FOR
22087 *COPY DT_RM2
22088 *
22089 *===RM2================================================================*
22090 *
22091       DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22092
22093       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22094       SAVE
22095
22096       PARAMETER ( LINP = 10 ,
22097      &            LOUT = 6 ,
22098      &            LDAT = 9 )
22099
22100       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22101       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22102      &           PI    = TWOPI/TWO,
22103      &           GEV2MB = 0.38938D0)
22104
22105 * VDM parameter for photon-nucleus interactions
22106       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22107
22108       IF (RL2.LE.ZERO) THEN
22109          DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22110      &        (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22111      &         +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22112       ELSE
22113          TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22114          TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22115          DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22116      &       -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22117      &       +EPSPOL*(
22118      &         -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22119      &       -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22120       ENDIF
22121
22122       RETURN
22123       END
22124
22125 *$ CREATE DT_SAM2.FOR
22126 *COPY DT_SAM2
22127 *
22128 *===SAM2===============================================================*
22129 *
22130       DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22131
22132       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22133       SAVE
22134
22135       PARAMETER ( LINP = 10 ,
22136      &            LOUT = 6 ,
22137      &            LDAT = 9 )
22138
22139       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22140      &           TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22141       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22142      &           PI    = TWOPI/TWO,
22143      &           GEV2MB = 0.38938D0)
22144
22145 * particle properties (BAMJET index convention)
22146       CHARACTER*8  ANAME
22147       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22148      &                IICH(210),IIBAR(210),K1(210),K2(210)
22149
22150 * VDM parameter for photon-nucleus interactions
22151       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22152
22153       S = ECM**2
22154       IF (INTRGE(1).EQ.1) THEN
22155          AMLO2 = (3.0D0*AAM(13))**2
22156       ELSEIF (INTRGE(1).EQ.2) THEN
22157          AMLO2 = AAM(33)**2
22158       ELSE
22159          AMLO2 = AAM(96)**2
22160       ENDIF
22161       IF (INTRGE(2).EQ.1) THEN
22162          AMHI2 = S/TWO
22163       ELSEIF (INTRGE(2).EQ.2) THEN
22164          AMHI2 = S/4.0D0
22165       ELSE
22166          AMHI2 = S
22167       ENDIF
22168       AMHI20 = (ECM-AAM(1))**2
22169       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22170
22171       AM1C2 = 16.0D0
22172       AM2C2 = 121.0D0
22173       YLO   = LOG(AMLO2+Q2)
22174       YC1   = LOG(AM1C2+Q2)
22175       YC2   = LOG(AM2C2+Q2)
22176       YHI   = LOG(AMHI2+Q2)
22177       IF (AMHI2.LE.AM1C2) THEN
22178          FACHI = TWO
22179       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22180          FACHI = TENTRD
22181       ELSE
22182          FACHI = ELVTRD
22183       ENDIF
22184
22185     1 CONTINUE
22186       YSAM2  = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22187       IF (YSAM2.LE.YC1) THEN
22188          FAC = TWO
22189       ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22190          FAC = TENTRD
22191       ELSE
22192          FAC = ELVTRD
22193       ENDIF
22194       WEIGMX = FACHI*(ONE-Q2*EXP(  -YHI))
22195       XSAM2  = FAC  *(ONE-Q2*EXP(-YSAM2))
22196       IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22197
22198       DT_SAM2   = EXP(YSAM2)-Q2
22199
22200       RETURN
22201       END
22202
22203 *$ CREATE DT_CKMT.FOR
22204 *COPY DT_CKMT
22205 *
22206 *===ckmt===============================================================*
22207 *
22208       SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22209      &                F2,IPAR)
22210
22211 ************************************************************************
22212 * This version dated 31.01.96 is written by S. Roesler                 *
22213 ************************************************************************
22214
22215       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22216       SAVE
22217
22218       PARAMETER ( LINP = 10 ,
22219      &            LOUT = 6 ,
22220      &            LDAT = 9 )
22221
22222       PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22223
22224       PARAMETER (Q02 = 2.0D0,
22225      &           DQ2 = 10.05D0,
22226      &           Q12 = Q02+DQ2)
22227
22228       DIMENSION PD(-6:6),SEA(3),VAL(2)
22229
22230       CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22231       CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22232       ADQ2 = LOG10(Q12)-LOG10(Q02)
22233       F2P  = (F2Q1-F2Q0)/ADQ2
22234       CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22235       CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22236       F2PP = (F2PQ1-F2PQ0)/ADQ2
22237       FX   = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22238
22239       Q2     = MAX(SCALE**2.0D0,TINY10)
22240       SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22241       IF (Q2.LT.Q02) THEN
22242          CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22243          UPV  = VAL(1)
22244          DNV  = VAL(2)
22245          USEA = SEA(1)
22246          DSEA = SEA(2)
22247          STR  = SEA(3)
22248          CHM  = 0.0D0
22249          BOT  = 0.0D0
22250          TOP  = 0.0D0
22251          GL   = GLU
22252       ELSE
22253          CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22254          F2 = F2*SMOOTH
22255          UPV  = PD(2)-PD(3)
22256          DNV  = PD(1)-PD(3)
22257          USEA = PD(3)
22258          DSEA = PD(3)
22259          STR  = PD(3)
22260          CHM  = PD(4)
22261          BOT  = PD(5)
22262          TOP  = PD(6)
22263          GL   = PD(0)
22264 C        UPV  = UPV*SMOOTH
22265 C        DNV  = DNV*SMOOTH
22266 C        USEA = USEA*SMOOTH
22267 C        DSEA = DSEA*SMOOTH
22268 C        STR  = STR*SMOOTH
22269 C        CHM  = CHM*SMOOTH
22270 C        GL   = GL*SMOOTH
22271       ENDIF
22272
22273       RETURN
22274       END
22275 C
22276
22277 *$ CREATE DT_CKMTX.FOR
22278 *COPY DT_CKMTX
22279       SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22280 C**********************************************************************
22281 C
22282 C     PDF based on Regge theory, evolved with .... by ....
22283 C
22284 C     input: IPAR     2212   proton (not installed)
22285 C                       45   Pomeron
22286 C                      100   Deuteron
22287 C
22288 C     output: PD(-6:6) x*f(x)  parton distribution functions
22289 C            (PDFLIB convention: d = PD(1), u = PD(2) )
22290 C
22291 C**********************************************************************
22292
22293       SAVE
22294       DOUBLE PRECISION  X,SCALE2,PD(-6:6),CDN,CUP,F2
22295
22296       PARAMETER ( LINP = 10 ,
22297      &            LOUT = 6 ,
22298      &            LDAT = 9 )
22299
22300       DIMENSION QQ(7)
22301 C
22302       Q2=SNGL(SCALE2)
22303       Q1S=Q2
22304       XX=SNGL(X)
22305 C  QCD lambda for evolution
22306       OWLAM = 0.23D0
22307       OWLAM2=OWLAM**2
22308 C  Q0**2 for evolution
22309       Q02 = 2.D0
22310 C
22311 C
22312 C  the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22313 C                        q(6)=x*charm, q(7)=x*gluon
22314 C
22315       SB=0.
22316       IF(Q2-Q02) 1,1,2
22317     2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22318     1 CONTINUE
22319       IF(IPAR.EQ.2212) THEN
22320         CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22321         CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22322         CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22323         CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22324         CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22325         CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22326         CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22327 C     ELSEIF (IPAR.EQ.45) THEN
22328 C       CALL CKMTPO(1,0,XX,SB,QQ(1))
22329 C       CALL CKMTPO(2,0,XX,SB,QQ(2))
22330 C       CALL CKMTPO(3,0,XX,SB,QQ(3))
22331 C       CALL CKMTPO(4,0,XX,SB,QQ(4))
22332 C       CALL CKMTPO(5,0,XX,SB,QQ(5))
22333 C       CALL CKMTPO(8,0,XX,SB,QQ(6))
22334 C       CALL CKMTPO(7,0,XX,SB,QQ(7))
22335       ELSEIF (IPAR.EQ.100) THEN
22336         CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22337         CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22338         CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22339         CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22340         CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22341         CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22342         CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22343       ELSE
22344         WRITE(LOUT,'(1X,A,I4,A)')
22345      &     'CKMTX:   IPAR =',IPAR,' not implemented!'
22346         STOP
22347       ENDIF
22348 C
22349       PD(-6) = 0.D0
22350       PD(-5) = 0.D0
22351       PD(-4) = DBLE(QQ(6))
22352       PD(-3) = DBLE(QQ(3))
22353       PD(-2) = DBLE(QQ(4))
22354       PD(-1) = DBLE(QQ(5))
22355       PD(0)  = DBLE(QQ(7))
22356       PD(1)  = DBLE(QQ(2))
22357       PD(2)  = DBLE(QQ(1))
22358       PD(3)  = DBLE(QQ(3))
22359       PD(4)  = DBLE(QQ(6))
22360       PD(5)  = 0.D0
22361       PD(6)  = 0.D0
22362       IF(IPAR.EQ.45) THEN
22363         CDN = (PD(1)-PD(-1))/2.D0
22364         CUP = (PD(2)-PD(-2))/2.D0
22365         PD(-1) = PD(-1) + CDN
22366         PD(-2) = PD(-2) + CUP
22367         PD(1) = PD(-1)
22368         PD(2) = PD(-2)
22369       ENDIF
22370       F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22371      &     1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22372      &     1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22373       END
22374 C
22375
22376 *$ CREATE DT_PDF0.FOR
22377 *COPY DT_PDF0
22378 *
22379 *===pdf0===============================================================*
22380 *
22381       SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22382
22383 ************************************************************************
22384 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22385 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22386 *                   IPAR  = 2212   proton                              *
22387 *                         =  100   deuteron                            *
22388 * This version dated 31.01.96 is written by S. Roesler                 *
22389 ************************************************************************
22390
22391       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22392       SAVE
22393
22394       PARAMETER ( LINP = 10 ,
22395      &            LOUT = 6 ,
22396      &            LDAT = 9 )
22397
22398       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22399
22400       PARAMETER (
22401      &              AA     = 0.1502D0,
22402      &              BBDEU  = 1.2D0,
22403      &              BUD    = 0.754D0,
22404      &              BDD    = 0.4495D0,
22405      &              BUP    = 1.2064D0,
22406      &              BDP    = 0.1798D0,
22407      &              DELTA0 = 0.07684D0,
22408      &              D      = 1.117D0,
22409      &              C      = 3.5489D0,
22410      &              A      = 0.2631D0,
22411      &              B      = 0.6452D0,
22412      &              ALPHAR = 0.415D0,
22413      &              E      = 0.1D0
22414      &          )
22415
22416       PARAMETER (NPOINT=16)
22417 C     DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22418       DIMENSION SEA(3),VAL(2)
22419
22420       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22421       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22422 * proton, deuteron
22423       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22424          CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22425          SEA(1) = 0.75D0*SEA0
22426          SEA(2) = SEA(1)
22427          SEA(3) = SEA(1)
22428          VAL(1) = 9.0D0/4.0D0*VALU0
22429          VAL(2) = 9.0D0*VALD0
22430          GLU0   = SEA(1)/(1.0D0-X)
22431          F2     = SEA0+VALU0+VALD0
22432          F2PDF  = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22433      &            1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22434      &            1.0D0/9.0D0*(2.0D0*SEA(3))
22435          IF (ABS(F2-F2PDF).GT.TINY9) THEN
22436             WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22437             STOP
22438          ENDIF
22439 **PHOJET105a
22440 C        CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22441 **PHOJET112
22442
22443 C        CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22444
22445 **
22446 C        SUMQ = ZERO
22447 C        SUMG = ZERO
22448 C        DO 1 J=1,NPOINT
22449 C           CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22450 C           VALU0 = 9.0D0/4.0D0*VALU0
22451 C           VALD0 = 9.0D0*VALD0
22452 C           SEA0  = 0.75D0*SEA0
22453 C           SUMQ  = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22454 C           SUMG  = SUMG+ (SEA0/(1.0D0-ABSZX(J)))  *WEIGHT(J)
22455 C   1    CONTINUE
22456 C        GLU = GLU0*(1.0D0-SUMQ)/SUMG
22457       ELSE
22458          WRITE(LOUT,'(1X,A,I4,A)')
22459      &      'PDF0:   IPAR =',IPAR,' not implemented!'
22460          STOP
22461       ENDIF
22462
22463       RETURN
22464       END
22465
22466 *$ CREATE DT_CKMTQ0.FOR
22467 *COPY DT_CKMTQ0
22468 *
22469 *===ckmtq0=============================================================*
22470 *
22471       SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22472
22473 ************************************************************************
22474 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22475 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22476 *                   IPAR  = 2212   proton                              *
22477 *                         =  100   deuteron                            *
22478 * This version dated 31.01.96 is written by S. Roesler                 *
22479 ************************************************************************
22480
22481       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22482       SAVE
22483
22484       PARAMETER ( LINP = 10 ,
22485      &            LOUT = 6 ,
22486      &            LDAT = 9 )
22487
22488       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22489
22490       PARAMETER (
22491      &              AA     = 0.1502D0,
22492      &              BBDEU  = 1.2D0,
22493      &              BUD    = 0.754D0,
22494      &              BDD    = 0.4495D0,
22495      &              BUP    = 1.2064D0,
22496      &              BDP    = 0.1798D0,
22497      &              DELTA0 = 0.07684D0,
22498      &              D      = 1.117D0,
22499      &              C      = 3.5489D0,
22500      &              A      = 0.2631D0,
22501      &              B      = 0.6452D0,
22502      &              ALPHAR = 0.415D0,
22503      &              E      = 0.1D0
22504      &          )
22505
22506       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22507       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22508 * proton, deuteron
22509       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22510          IF (IPAR.EQ.2212) THEN
22511             BU = BUP
22512             BD = BDP
22513          ELSE
22514             BU = BUD
22515             BD = BDD
22516          ENDIF
22517          SEA0  = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22518      &          (Q2/(Q2+A))**(1.0D0+DELTA)
22519          VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22520      &           (Q2/(Q2+B))**(ALPHAR)
22521          VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22522      &           (Q2/(Q2+B))**(ALPHAR)
22523       ELSE
22524          WRITE(LOUT,'(1X,A,I4,A)')
22525      &      'CKMTQ0: IPAR =',IPAR,' not implemented!'
22526          STOP
22527       ENDIF
22528       RETURN
22529       END
22530 C
22531 C
22532
22533 *$ CREATE DT_CKMTDE.FOR
22534 *COPY DT_CKMTDE
22535       SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22536 C
22537 C**********************************************************************
22538 C    Deuteron - PDFs
22539 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22540 C    ANS = PDF(I)
22541 C    This version by S. Roesler, 30.01.96
22542 C**********************************************************************
22543
22544       SAVE
22545       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22546       EQUIVALENCE (GF(1,1,1),DL(1))
22547       DATA DELTA/.13/
22548 C
22549       DATA (DL(K),K=    1,   85) /
22550      &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22551      &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22552      &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22553      &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22554      &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22555      &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22556      &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22557      &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22558      &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22559      &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22560      &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22561      &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22562      &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22563      &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22564      &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22565      &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22566      &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22567       DATA (DL(K),K=   86,  170) /
22568      &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22569      &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22570      &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22571      &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22572      &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22573      &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22574      &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22575      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22576      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22577      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22578      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22579      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22580      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22581      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22582      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22583      &0.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22584      &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22585       DATA (DL(K),K=  171,  255) /
22586      &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22587      &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22588      &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22589      &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22590      &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22591      &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22592      &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22593      &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22594      &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22595      &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22596      &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22597      &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22598      &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22599      &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22600      &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22601      &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22602      &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22603       DATA (DL(K),K=  256,  340) /
22604      &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22605      &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22606      &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22607      &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22608      &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22609      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22610      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22611      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22612      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22613      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22614      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22615      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22616      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22617      &0.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22618      &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22619      &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22620      &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22621       DATA (DL(K),K=  341,  425) /
22622      &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22623      &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22624      &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22625      &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22626      &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22627      &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22628      &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22629      &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22630      &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22631      &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22632      &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22633      &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22634      &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22635      &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22636      &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22637      &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22638      &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22639       DATA (DL(K),K=  426,  510) /
22640      &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22641      &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22642      &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22643      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22644      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22645      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22646      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22647      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22648      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22649      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22650      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22651      &0.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22652      &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22653      &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22654      &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22655      &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22656      &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22657       DATA (DL(K),K=  511,  595) /
22658      &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22659      &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22660      &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22661      &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22662      &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22663      &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22664      &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22665      &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22666      &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22667      &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22668      &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22669      &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22670      &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22671      &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22672      &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
22673      &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
22674      &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
22675       DATA (DL(K),K=  596,  680) /
22676      &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
22677      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22678      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22679      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22680      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22681      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22682      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22683      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22684      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22685      &0.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22686      &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
22687      &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
22688      &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
22689      &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
22690      &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
22691      &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
22692      &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
22693       DATA (DL(K),K=  681,  765) /
22694      &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
22695      &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
22696      &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
22697      &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
22698      &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
22699      &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
22700      &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
22701      &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
22702      &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
22703      &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
22704      &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
22705      &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
22706      &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
22707      &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
22708      &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
22709      &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
22710      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22711       DATA (DL(K),K=  766,  850) /
22712      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22713      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22714      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22715      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22716      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22717      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22718      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22719      &0.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
22720      &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
22721      &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
22722      &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
22723      &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
22724      &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
22725      &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
22726      &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
22727      &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
22728      &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
22729       DATA (DL(K),K=  851,  935) /
22730      &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
22731      &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
22732      &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
22733      &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
22734      &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
22735      &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
22736      &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
22737      &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
22738      &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
22739      &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
22740      &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
22741      &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
22742      &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
22743      &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
22744      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22745      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22746      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22747       DATA (DL(K),K=  936, 1020) /
22748      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22749      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22750      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22751      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22752      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22753      &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
22754      &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
22755      &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
22756      &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
22757      &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
22758      &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
22759      &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
22760      &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
22761      &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
22762      &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
22763      &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
22764      &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
22765       DATA (DL(K),K= 1021, 1105) /
22766      &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
22767      &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
22768      &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
22769      &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
22770      &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
22771      &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
22772      &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
22773      &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
22774      &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
22775      &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
22776      &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
22777      &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
22778      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22779      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22780      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22781      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22782      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22783       DATA (DL(K),K= 1106, 1190) /
22784      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22785      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22786      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22787      &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
22788      &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
22789      &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
22790      &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
22791      &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
22792      &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
22793      &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
22794      &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
22795      &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
22796      &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
22797      &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
22798      &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
22799      &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
22800      &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
22801       DATA (DL(K),K= 1191, 1275) /
22802      &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
22803      &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
22804      &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
22805      &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
22806      &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
22807      &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
22808      &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
22809      &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
22810      &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
22811      &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
22812      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22813      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22814      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22815      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22816      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22817      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22818      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22819       DATA (DL(K),K= 1276, 1360) /
22820      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22821      &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
22822      &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
22823      &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
22824      &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
22825      &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
22826      &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
22827      &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
22828      &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
22829      &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
22830      &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
22831      &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
22832      &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
22833      &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
22834      &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
22835      &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
22836      &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
22837       DATA (DL(K),K= 1361, 1445) /
22838      &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
22839      &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
22840      &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
22841      &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
22842      &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
22843      &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
22844      &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
22845      &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
22846      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22847      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22848      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22849      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22850      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22851      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22852      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22853      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22854      &0.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
22855       DATA (DL(K),K= 1446, 1530) /
22856      &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
22857      &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
22858      &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
22859      &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
22860      &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
22861      &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
22862      &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
22863      &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
22864      &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
22865      &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
22866      &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
22867      &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
22868      &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
22869      &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
22870      &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
22871      &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
22872      &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
22873       DATA (DL(K),K= 1531, 1615) /
22874      &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
22875      &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
22876      &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
22877      &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
22878      &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
22879      &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
22880      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22881      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22882      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22883      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22884      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22885      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22886      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22887      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22888      &0.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
22889      &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
22890      &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
22891       DATA (DL(K),K= 1616, 1700) /
22892      &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
22893      &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
22894      &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
22895      &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
22896      &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
22897      &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
22898      &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
22899      &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
22900      &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
22901      &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
22902      &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
22903      &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
22904      &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
22905      &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
22906      &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
22907      &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
22908      &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
22909       DATA (DL(K),K= 1701, 1785) /
22910      &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
22911      &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
22912      &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
22913      &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
22914      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22915      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22916      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22917      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22918      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22919      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22920      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22921      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22922      &0.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
22923      &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
22924      &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
22925      &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
22926      &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
22927       DATA (DL(K),K= 1786, 1870) /
22928      &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
22929      &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
22930      &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
22931      &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
22932      &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
22933      &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
22934      &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
22935      &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
22936      &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
22937      &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
22938      &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
22939      &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
22940      &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
22941      &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
22942      &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
22943      &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
22944      &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
22945       DATA (DL(K),K= 1871, 1955) /
22946      &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
22947      &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
22948      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22949      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22950      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22951      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22952      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22953      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22954      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22955      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22956      &0.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
22957      &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
22958      &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
22959      &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
22960      &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
22961      &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
22962      &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
22963       DATA (DL(K),K= 1956, 2040) /
22964      &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
22965      &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
22966      &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
22967      &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
22968      &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
22969      &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
22970      &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
22971      &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
22972      &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
22973      &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
22974      &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
22975      &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
22976      &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
22977      &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
22978      &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
22979      &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
22980      &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
22981       DATA (DL(K),K= 2041, 2125) /
22982      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22983      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22984      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22985      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22986      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22987      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22988      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22989      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22990      &0.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
22991      &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
22992      &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
22993      &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
22994      &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
22995      &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
22996      &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
22997      &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
22998      &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
22999       DATA (DL(K),K= 2126, 2210) /
23000      &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
23001      &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
23002      &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
23003      &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
23004      &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23005      &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23006      &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23007      &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23008      &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23009      &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23010      &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23011      &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23012      &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23013      &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23014      &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23015      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23016      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23017       DATA (DL(K),K= 2211, 2295) /
23018      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23019      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23020      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23021      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23022      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23023      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23024      &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23025      &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23026      &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23027      &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23028      &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23029      &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23030      &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23031      &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23032      &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23033      &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23034      &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23035       DATA (DL(K),K= 2296, 2380) /
23036      &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23037      &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23038      &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23039      &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23040      &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23041      &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23042      &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23043      &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23044      &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23045      &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23046      &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23047      &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23048      &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23049      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23050      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23051      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23052      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23053       DATA (DL(K),K= 2381, 2465) /
23054      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23055      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23056      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23057      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23058      &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23059      &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23060      &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23061      &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23062      &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23063      &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23064      &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23065      &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23066      &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23067      &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23068      &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23069      &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23070      &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23071       DATA (DL(K),K= 2466, 2550) /
23072      &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23073      &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23074      &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23075      &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23076      &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23077      &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23078      &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23079      &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23080      &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23081      &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23082      &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23083      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23084      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23085      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23086      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23087      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23088      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23089       DATA (DL(K),K= 2551, 2635) /
23090      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23091      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23092      &0.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23093      &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23094      &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23095      &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23096      &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23097      &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23098      &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23099      &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23100      &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23101      &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23102      &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23103      &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23104      &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23105      &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23106      &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23107       DATA (DL(K),K= 2636, 2720) /
23108      &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23109      &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23110      &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23111      &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23112      &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23113      &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23114      &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23115      &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23116      &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23117      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23118      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23119      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23120      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23121      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23122      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23123      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23124      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23125       DATA (DL(K),K= 2721, 2805) /
23126      &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23127      &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23128      &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23129      &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23130      &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23131      &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23132      &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23133      &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23134      &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23135      &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23136      &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23137      &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23138      &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23139      &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23140      &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23141      &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23142      &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23143       DATA (DL(K),K= 2806, 2890) /
23144      &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23145      &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23146      &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23147      &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23148      &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23149      &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23150      &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23151      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23152      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23153      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23154      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23155      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23156      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23157      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23158      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23159      &0.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23160      &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23161       DATA (DL(K),K= 2891, 2975) /
23162      &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23163      &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23164      &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23165      &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23166      &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23167      &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23168      &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23169      &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23170      &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23171      &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23172      &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23173      &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23174      &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23175      &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23176      &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23177      &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23178      &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23179       DATA (DL(K),K= 2976, 3060) /
23180      &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23181      &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23182      &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23183      &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23184      &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23185      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23186      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23187      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23188      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23189      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23190      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23191      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23192      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23193      &0.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23194      &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23195      &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23196      &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23197       DATA (DL(K),K= 3061, 3145) /
23198      &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23199      &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23200      &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23201      &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23202      &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23203      &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23204      &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23205      &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23206      &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23207      &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23208      &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23209      &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23210      &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23211      &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23212      &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23213      &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23214      &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23215       DATA (DL(K),K= 3146, 3230) /
23216      &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23217      &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23218      &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23219      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23220      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23221      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23222      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23223      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23224      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23225      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23226      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23227      &0.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23228      &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23229      &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23230      &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23231      &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23232      &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23233       DATA (DL(K),K= 3231, 3315) /
23234      &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23235      &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23236      &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23237      &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23238      &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23239      &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23240      &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23241      &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23242      &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23243      &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23244      &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23245      &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23246      &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23247      &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23248      &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23249      &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23250      &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23251       DATA (DL(K),K= 3316, 3400) /
23252      &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23253      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23254      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23255      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23256      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23257      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23258      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23259      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23260      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23261      &0.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23262      &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23263      &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23264      &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23265      &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23266      &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23267      &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23268      &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23269       DATA (DL(K),K= 3401, 3485) /
23270      &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23271      &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23272      &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23273      &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23274      &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23275      &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23276      &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23277      &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23278      &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23279      &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23280      &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23281      &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23282      &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23283      &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23284      &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23285      &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23286      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23287       DATA (DL(K),K= 3486, 3570) /
23288      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23289      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23290      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23291      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23292      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23293      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23294      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23295      &0.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23296      &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23297      &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23298      &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23299      &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23300      &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23301      &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23302      &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23303      &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23304      &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23305       DATA (DL(K),K= 3571, 3655) /
23306      &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23307      &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23308      &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23309      &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23310      &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23311      &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23312      &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23313      &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23314      &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23315      &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23316      &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23317      &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23318      &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23319      &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23320      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23321      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23322      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23323       DATA (DL(K),K= 3656, 3740) /
23324      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23325      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23326      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23327      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23328      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23329      &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23330      &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23331      &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23332      &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23333      &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23334      &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23335      &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23336      &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23337      &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23338      &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23339      &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23340      &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23341       DATA (DL(K),K= 3741, 3825) /
23342      &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23343      &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23344      &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23345      &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23346      &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23347      &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23348      &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23349      &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23350      &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23351      &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23352      &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23353      &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23354      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23355      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23356      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23357      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23358      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23359       DATA (DL(K),K= 3826, 3910) /
23360      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23361      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23362      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23363      &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23364      &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23365      &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23366      &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23367      &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23368      &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23369      &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23370      &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23371      &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23372      &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23373      &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23374      &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23375      &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23376      &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23377       DATA (DL(K),K= 3911, 3995) /
23378      &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23379      &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23380      &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23381      &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23382      &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23383      &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23384      &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23385      &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23386      &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23387      &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23388      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23389      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23390      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23391      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23392      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23393      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23394      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23395       DATA (DL(K),K= 3996, 4000) /
23396      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23397 C
23398       ANS = 0.
23399       IF (X.GT.0.9985) RETURN
23400       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23401 C
23402       IS  = S/DELTA+1
23403       IS1 = IS+1
23404       DO 1 L=1,25
23405          KL    = L+NDRV*25
23406          F1(L) = GF(I,IS,KL)
23407          F2(L) = GF(I,IS1,KL)
23408     1 CONTINUE
23409       A1 = DT_CKMTFF(X,F1)
23410       A2 = DT_CKMTFF(X,F2)
23411 C      A1=ALOG(A1)
23412 C      A2=ALOG(A2)
23413       S1  = (IS-1)*DELTA
23414       S2  = S1+DELTA
23415       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23416 C      ANS=EXP(ANS)
23417       RETURN
23418       END
23419 C
23420 C
23421
23422 *$ CREATE DT_CKMTPR.FOR
23423 *COPY DT_CKMTPR
23424       SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23425 C
23426 C**********************************************************************
23427 C    Proton   - PDFs
23428 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23429 C    ANS = PDF(I)
23430 C    This version by S. Roesler, 31.01.96
23431 C**********************************************************************
23432
23433       SAVE
23434       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23435       EQUIVALENCE (GF(1,1,1),DL(1))
23436       DATA DELTA/.10/
23437 C
23438       DATA (DL(K),K=    1,   85) /
23439      &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23440      &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23441      &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23442      &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23443      &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23444      &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23445      &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23446      &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23447      &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23448      &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23449      &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23450      &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23451      &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23452      &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23453      &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23454      &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23455      &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23456       DATA (DL(K),K=   86,  170) /
23457      &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23458      &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23459      &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23460      &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23461      &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23462      &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23463      &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23464      &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23465      &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23466      &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23467      &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23468      &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23469      &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23470      &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23471      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23472      &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23473      &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23474       DATA (DL(K),K=  171,  255) /
23475      &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23476      &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23477      &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23478      &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23479      &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23480      &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23481      &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23482      &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23483      &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23484      &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23485      &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23486      &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23487      &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23488      &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23489      &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23490      &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23491      &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23492       DATA (DL(K),K=  256,  340) /
23493      &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23494      &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23495      &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23496      &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23497      &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23498      &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23499      &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23500      &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23501      &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23502      &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23503      &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23504      &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23505      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23506      &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23507      &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23508      &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23509      &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23510       DATA (DL(K),K=  341,  425) /
23511      &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23512      &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23513      &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23514      &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23515      &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23516      &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23517      &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23518      &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23519      &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23520      &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23521      &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23522      &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23523      &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23524      &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23525      &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23526      &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23527      &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23528       DATA (DL(K),K=  426,  510) /
23529      &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23530      &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23531      &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23532      &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23533      &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23534      &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23535      &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23536      &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23537      &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23538      &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23539      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23540      &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23541      &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23542      &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23543      &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23544      &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23545      &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23546       DATA (DL(K),K=  511,  595) /
23547      &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23548      &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23549      &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23550      &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23551      &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23552      &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23553      &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23554      &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23555      &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23556      &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23557      &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23558      &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23559      &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23560      &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23561      &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23562      &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23563      &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23564       DATA (DL(K),K=  596,  680) /
23565      &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23566      &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23567      &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23568      &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23569      &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23570      &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23571      &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23572      &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23573      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23574      &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23575      &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23576      &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23577      &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23578      &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23579      &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23580      &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23581      &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23582       DATA (DL(K),K=  681,  765) /
23583      &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23584      &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23585      &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23586      &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23587      &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23588      &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23589      &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23590      &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23591      &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23592      &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23593      &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23594      &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23595      &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23596      &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23597      &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23598      &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23599      &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23600       DATA (DL(K),K=  766,  850) /
23601      &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23602      &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23603      &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23604      &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23605      &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23606      &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23607      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23608      &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23609      &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23610      &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23611      &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23612      &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23613      &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23614      &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23615      &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23616      &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23617      &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23618       DATA (DL(K),K=  851,  935) /
23619      &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23620      &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23621      &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23622      &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23623      &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23624      &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23625      &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23626      &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23627      &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23628      &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23629      &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23630      &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23631      &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23632      &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23633      &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23634      &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23635      &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23636       DATA (DL(K),K=  936, 1020) /
23637      &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23638      &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23639      &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23640      &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23641      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23642      &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23643      &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23644      &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23645      &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23646      &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23647      &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23648      &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23649      &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23650      &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23651      &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23652      &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23653      &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23654       DATA (DL(K),K= 1021, 1105) /
23655      &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23656      &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23657      &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23658      &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23659      &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23660      &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23661      &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23662      &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23663      &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23664      &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23665      &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23666      &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23667      &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23668      &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23669      &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23670      &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23671      &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23672       DATA (DL(K),K= 1106, 1190) /
23673      &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
23674      &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23675      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23676      &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23677      &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
23678      &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
23679      &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
23680      &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
23681      &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
23682      &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
23683      &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
23684      &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
23685      &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
23686      &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
23687      &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
23688      &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
23689      &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
23690       DATA (DL(K),K= 1191, 1275) /
23691      &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
23692      &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
23693      &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
23694      &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
23695      &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
23696      &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
23697      &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
23698      &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
23699      &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
23700      &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
23701      &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
23702      &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
23703      &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
23704      &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
23705      &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
23706      &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
23707      &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
23708       DATA (DL(K),K= 1276, 1360) /
23709      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23710      &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23711      &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
23712      &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
23713      &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
23714      &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
23715      &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
23716      &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
23717      &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
23718      &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
23719      &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
23720      &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
23721      &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
23722      &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
23723      &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
23724      &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
23725      &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
23726       DATA (DL(K),K= 1361, 1445) /
23727      &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
23728      &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
23729      &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
23730      &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
23731      &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
23732      &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
23733      &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
23734      &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
23735      &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
23736      &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
23737      &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
23738      &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
23739      &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
23740      &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
23741      &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23742      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23743      &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23744       DATA (DL(K),K= 1446, 1530) /
23745      &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
23746      &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
23747      &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
23748      &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
23749      &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
23750      &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
23751      &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
23752      &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
23753      &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
23754      &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
23755      &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
23756      &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
23757      &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
23758      &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
23759      &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
23760      &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
23761      &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
23762       DATA (DL(K),K= 1531, 1615) /
23763      &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
23764      &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
23765      &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
23766      &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
23767      &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
23768      &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
23769      &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
23770      &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
23771      &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
23772      &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
23773      &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
23774      &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
23775      &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23776      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23777      &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23778      &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
23779      &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
23780       DATA (DL(K),K= 1616, 1700) /
23781      &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
23782      &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
23783      &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
23784      &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
23785      &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
23786      &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
23787      &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
23788      &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
23789      &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
23790      &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
23791      &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
23792      &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
23793      &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
23794      &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
23795      &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
23796      &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
23797      &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
23798       DATA (DL(K),K= 1701, 1785) /
23799      &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
23800      &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
23801      &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
23802      &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
23803      &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
23804      &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
23805      &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
23806      &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
23807      &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
23808      &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
23809      &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23810      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23811      &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23812      &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
23813      &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
23814      &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
23815      &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
23816       DATA (DL(K),K= 1786, 1870) /
23817      &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
23818      &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
23819      &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
23820      &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
23821      &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
23822      &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
23823      &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
23824      &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
23825      &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
23826      &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
23827      &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
23828      &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
23829      &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
23830      &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
23831      &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
23832      &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
23833      &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
23834       DATA (DL(K),K= 1871, 1955) /
23835      &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
23836      &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
23837      &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
23838      &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
23839      &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
23840      &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
23841      &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
23842      &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
23843      &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23844      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23845      &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23846      &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
23847      &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
23848      &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
23849      &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
23850      &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
23851      &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
23852       DATA (DL(K),K= 1956, 2040) /
23853      &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
23854      &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
23855      &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
23856      &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
23857      &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
23858      &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
23859      &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
23860      &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
23861      &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
23862      &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
23863      &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
23864      &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
23865      &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
23866      &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
23867      &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
23868      &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
23869      &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
23870       DATA (DL(K),K= 2041, 2125) /
23871      &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
23872      &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
23873      &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
23874      &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
23875      &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
23876      &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
23877      &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23878      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23879      &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23880      &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
23881      &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
23882      &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
23883      &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
23884      &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
23885      &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
23886      &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
23887      &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
23888       DATA (DL(K),K= 2126, 2210) /
23889      &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
23890      &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
23891      &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
23892      &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
23893      &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
23894      &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
23895      &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
23896      &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
23897      &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
23898      &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
23899      &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
23900      &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
23901      &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
23902      &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
23903      &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
23904      &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
23905      &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
23906       DATA (DL(K),K= 2211, 2295) /
23907      &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
23908      &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
23909      &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
23910      &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
23911      &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23912      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23913      &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23914      &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
23915      &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
23916      &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
23917      &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
23918      &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
23919      &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
23920      &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
23921      &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
23922      &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
23923      &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
23924       DATA (DL(K),K= 2296, 2380) /
23925      &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
23926      &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
23927      &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
23928      &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
23929      &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
23930      &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
23931      &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
23932      &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
23933      &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
23934      &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
23935      &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
23936      &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
23937      &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
23938      &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
23939      &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
23940      &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
23941      &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
23942       DATA (DL(K),K= 2381, 2465) /
23943      &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
23944      &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
23945      &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23946      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23947      &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23948      &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
23949      &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
23950      &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
23951      &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
23952      &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
23953      &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
23954      &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
23955      &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
23956      &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
23957      &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
23958      &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
23959      &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
23960       DATA (DL(K),K= 2466, 2550) /
23961      &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
23962      &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
23963      &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
23964      &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
23965      &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
23966      &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
23967      &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
23968      &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
23969      &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
23970      &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
23971      &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
23972      &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
23973      &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
23974      &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
23975      &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
23976      &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
23977      &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
23978       DATA (DL(K),K= 2551, 2635) /
23979      &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
23980      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23981      &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
23982      &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
23983      &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
23984      &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
23985      &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
23986      &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
23987      &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
23988      &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
23989      &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
23990      &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
23991      &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
23992      &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
23993      &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
23994      &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
23995      &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
23996       DATA (DL(K),K= 2636, 2720) /
23997      &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
23998      &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
23999      &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
24000      &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
24001      &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
24002      &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
24003      &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
24004      &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24005      &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24006      &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24007      &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24008      &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24009      &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24010      &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24011      &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24012      &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24013      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24014       DATA (DL(K),K= 2721, 2805) /
24015      &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24016      &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24017      &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24018      &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24019      &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24020      &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24021      &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24022      &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24023      &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24024      &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24025      &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24026      &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24027      &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24028      &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24029      &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24030      &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24031      &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24032       DATA (DL(K),K= 2806, 2890) /
24033      &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24034      &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24035      &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24036      &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24037      &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24038      &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24039      &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24040      &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24041      &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24042      &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24043      &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24044      &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24045      &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24046      &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24047      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24048      &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24049      &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24050       DATA (DL(K),K= 2891, 2975) /
24051      &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24052      &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24053      &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24054      &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24055      &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24056      &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24057      &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24058      &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24059      &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24060      &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24061      &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24062      &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24063      &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24064      &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24065      &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24066      &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24067      &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24068       DATA (DL(K),K= 2976, 3060) /
24069      &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24070      &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24071      &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24072      &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24073      &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24074      &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24075      &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24076      &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24077      &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24078      &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24079      &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24080      &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24081      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24082      &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24083      &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24084      &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24085      &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24086       DATA (DL(K),K= 3061, 3145) /
24087      &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24088      &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24089      &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24090      &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24091      &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24092      &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24093      &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24094      &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24095      &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24096      &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24097      &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24098      &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24099      &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24100      &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24101      &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24102      &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24103      &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24104       DATA (DL(K),K= 3146, 3230) /
24105      &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24106      &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24107      &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24108      &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24109      &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24110      &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24111      &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24112      &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24113      &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24114      &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24115      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24116      &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24117      &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24118      &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24119      &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24120      &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24121      &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24122       DATA (DL(K),K= 3231, 3315) /
24123      &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24124      &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24125      &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24126      &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24127      &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24128      &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24129      &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24130      &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24131      &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24132      &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24133      &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24134      &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24135      &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24136      &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24137      &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24138      &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24139      &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24140       DATA (DL(K),K= 3316, 3400) /
24141      &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24142      &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24143      &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24144      &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24145      &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24146      &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24147      &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24148      &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24149      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24150      &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24151      &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24152      &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24153      &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24154      &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24155      &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24156      &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24157      &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24158       DATA (DL(K),K= 3401, 3485) /
24159      &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24160      &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24161      &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24162      &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24163      &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24164      &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24165      &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24166      &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24167      &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24168      &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24169      &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24170      &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24171      &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24172      &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24173      &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24174      &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24175      &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24176       DATA (DL(K),K= 3486, 3570) /
24177      &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24178      &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24179      &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24180      &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24181      &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24182      &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24183      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24184      &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24185      &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24186      &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24187      &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24188      &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24189      &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24190      &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24191      &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24192      &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24193      &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24194       DATA (DL(K),K= 3571, 3655) /
24195      &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24196      &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24197      &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24198      &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24199      &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24200      &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24201      &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24202      &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24203      &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24204      &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24205      &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24206      &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24207      &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24208      &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24209      &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24210      &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24211      &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24212       DATA (DL(K),K= 3656, 3740) /
24213      &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24214      &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24215      &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24216      &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24217      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24218      &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24219      &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24220      &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24221      &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24222      &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24223      &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24224      &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24225      &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24226      &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24227      &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24228      &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24229      &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24230       DATA (DL(K),K= 3741, 3825) /
24231      &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24232      &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24233      &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24234      &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24235      &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24236      &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24237      &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24238      &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24239      &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24240      &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24241      &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24242      &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24243      &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24244      &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24245      &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24246      &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24247      &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24248       DATA (DL(K),K= 3826, 3910) /
24249      &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24250      &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24251      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24252      &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24253      &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24254      &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24255      &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24256      &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24257      &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24258      &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24259      &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24260      &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24261      &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24262      &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24263      &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24264      &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24265      &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24266       DATA (DL(K),K= 3911, 3995) /
24267      &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24268      &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24269      &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24270      &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24271      &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24272      &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24273      &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24274      &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24275      &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24276      &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24277      &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24278      &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24279      &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24280      &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24281      &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24282      &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24283      &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24284       DATA (DL(K),K= 3996, 4000) /
24285      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24286 C
24287       ANS = 0.
24288       IF (X.GT.0.9985) RETURN
24289       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24290 C
24291       IS  = S/DELTA+1
24292       IS1 = IS+1
24293       DO 1 L=1,25
24294          KL    = L+NDRV*25
24295          F1(L) = GF(I,IS,KL)
24296          F2(L) = GF(I,IS1,KL)
24297     1 CONTINUE
24298       A1 = DT_CKMTFF(X,F1)
24299       A2 = DT_CKMTFF(X,F2)
24300 C      A1=ALOG(A1)
24301 C      A2=ALOG(A2)
24302       S1  = (IS-1)*DELTA
24303       S2  = S1+DELTA
24304       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24305 C      ANS=EXP(ANS)
24306       RETURN
24307       END
24308 C
24309
24310 *$ CREATE DT_CKMTFF.FOR
24311 *COPY DT_CKMTFF
24312       FUNCTION DT_CKMTFF(X,FVL)
24313 C**********************************************************************
24314 C
24315 C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24316 C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24317 C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24318 C     IN MAIN ROUTINE.
24319 C
24320 C**********************************************************************
24321
24322       SAVE
24323       DIMENSION FVL(25),XGRID(25)
24324       DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24325      *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24326 C
24327       DT_CKMTFF=0.
24328       DO 1 I=1,NX
24329       IF(X.LT.XGRID(I)) GO TO 2
24330     1 CONTINUE
24331     2 I=I-1
24332       IF(I.EQ.0) THEN
24333          I=I+1
24334       ELSE IF(I.GT.23) THEN
24335          I=23
24336       ENDIF
24337       J=I+1
24338       K=J+1
24339       AXI=LOG(XGRID(I))
24340       BXI=LOG(1.-XGRID(I))
24341       AXJ=LOG(XGRID(J))
24342       BXJ=LOG(1.-XGRID(J))
24343       AXK=LOG(XGRID(K))
24344       BXK=LOG(1.-XGRID(K))
24345       FI=LOG(ABS(FVL(I)) +1.E-15)
24346       FJ=LOG(ABS(FVL(J)) +1.E-16)
24347       FK=LOG(ABS(FVL(K)) +1.E-17)
24348       DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24349       ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24350      $ BXI))/DET
24351       ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24352       BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24353       IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24354      1RETURN
24355 C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24356 C         WRITE(6,2001) X,FVL
24357 C 2001    FORMAT(8E12.4)
24358 C         WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24359 C      ENDIF
24360       DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24361       RETURN
24362       END
24363
24364 *$ CREATE DT_FLUINI.FOR
24365 *COPY DT_FLUINI
24366 *
24367 *===fluini=============================================================*
24368 *
24369       SUBROUTINE DT_FLUINI
24370
24371 ************************************************************************
24372 * Initialisation of the nucleon-nucleon cross section fluctuation      *
24373 * treatment. The original version by J. Ranft.                         *
24374 * This version dated 21.04.95 is revised by S. Roesler.                *
24375 ************************************************************************
24376
24377       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24378       SAVE
24379
24380       PARAMETER ( LINP = 10 ,
24381      &            LOUT = 6 ,
24382      &            LDAT = 9 )
24383
24384       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24385
24386       PARAMETER ( A     = 0.1D0,
24387      &            B     = 0.893D0,
24388      &            OM    = 1.1D0,
24389      &            N     = 6,
24390      &            DX    = 0.003D0)
24391
24392 * n-n cross section fluctuations
24393       PARAMETER (NBINS = 1000)
24394       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24395       DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24396
24397       WRITE(LOUT,1000)
24398  1000 FORMAT(/,1X,'FLUINI:  hadronic cross section fluctuations ',
24399      &       'treated')
24400
24401       FLUSU  = ZERO
24402       FLUSUU = ZERO
24403
24404       DO 1 I=1,NBINS
24405          X        = DBLE(I)*DX
24406          FLUIX(I) = X
24407          FLUS     = ((X-B)/(OM*B))**N
24408          IF (FLUS.LE.20.0D0) THEN
24409             FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24410          ELSE
24411             FLUSI(I) = ZERO
24412          ENDIF
24413          FLUSU = FLUSU+FLUSI(I)
24414     1 CONTINUE
24415       DO 2 I=1,NBINS
24416          FLUSUU   = FLUSUU+FLUSI(I)/FLUSU
24417          FLUSI(I) = FLUSUU
24418     2 CONTINUE
24419
24420 C     WRITE(LOUT,1001)
24421 C1001 FORMAT(1X,'FLUCTUATIONS')
24422 C     CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24423
24424       DO 3 I=1,NBINS
24425          AF = DBLE(I)*0.001D0
24426          DO 4 J=1,NBINS
24427             IF (AF.LE.FLUSI(J)) THEN
24428                FLUIXX(I) = FLUIX(J)
24429                GOTO 5
24430             ENDIF
24431     4    CONTINUE
24432     5    CONTINUE
24433     3 CONTINUE
24434       FLUIXX(1)     = FLUIX(1)
24435       FLUIXX(NBINS) = FLUIX(NBINS)
24436
24437       RETURN
24438       END
24439
24440 *$ CREATE DT_SIGTBL.FOR
24441 *COPY DT_SIGTBL
24442 *
24443 *===sigtab=============================================================*
24444 *
24445       SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24446
24447 ************************************************************************
24448 * This version dated 18.11.95 is written by S. Roesler                 *
24449 ************************************************************************
24450
24451       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24452       SAVE
24453
24454       PARAMETER ( LINP = 10 ,
24455      &            LOUT = 6 ,
24456      &            LDAT = 9 )
24457
24458       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24459      &           OHALF=0.5D0,ONE=1.0D0)
24460       PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24461
24462       LOGICAL LINIT
24463
24464 * particle properties (BAMJET index convention)
24465       CHARACTER*8  ANAME
24466       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24467      &                IICH(210),IIBAR(210),K1(210),K2(210)
24468
24469       DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24470       DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24471      &             0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24472      &             0, 0, 5/
24473       DATA LINIT /.FALSE./
24474
24475 * precalculation and tabulation of elastic cross sections
24476       IF (ABS(MODE).EQ.1) THEN
24477          IF (MODE.EQ.1)
24478      &      OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24479          PLABLX = LOG10(PLO)
24480          PLABHX = LOG10(PHI)
24481          DPLAB  = (PLABHX-PLABLX)/DBLE(NBINS)
24482          DO 1 I=1,NBINS+1
24483             PLAB = PLABLX+DBLE(I-1)*DPLAB
24484             PLAB = 10**PLAB
24485             DO 2 IPROJ=1,23
24486                IDX = IDSIG(IPROJ)
24487                IF (IDX.GT.0) THEN
24488 C                 CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24489 C                 CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24490                   DUMZER = ZERO
24491                   CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24492                   CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24493                ENDIF
24494     2       CONTINUE
24495             IF (MODE.EQ.1) THEN
24496                WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24497      &                                (SIGEN(IDX,I),IDX=1,5)
24498  1000          FORMAT(F5.1,10F7.2)
24499             ENDIF
24500     1    CONTINUE
24501          IF (MODE.EQ.1) CLOSE(LDAT)
24502          LINIT = .TRUE.
24503       ELSE
24504          SIGE = -ONE
24505          IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24506      &                           .AND.(PTOT.LE.PHI) ) THEN
24507             IDX = IDSIG(JP)
24508             IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24509                PLABX = LOG10(PTOT)
24510                IF (PLABX.LE.PLABLX) THEN
24511                   I1 = 1
24512                   I2 = 1
24513                ELSEIF (PLABX.GE.PLABHX) THEN
24514                   I1 = NBINS+1
24515                   I2 = NBINS+1
24516                ELSE
24517                   I1 = INT((PLABX-PLABLX)/DPLAB)+1
24518                   I2 = I1+1
24519                ENDIF
24520                PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24521                PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24522                PBIN   = PLAB2X-PLAB1X
24523                IF (PBIN.GT.TINY10) THEN
24524                   RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24525                ELSE
24526                   RATX = ZERO
24527                ENDIF
24528                IF (JT.EQ.1) THEN
24529                   SIG1 = SIGEP(IDX,I1)
24530                   SIG2 = SIGEP(IDX,I2)
24531                ELSE
24532                   SIG1 = SIGEN(IDX,I1)
24533                   SIG2 = SIGEN(IDX,I2)
24534                ENDIF
24535                SIGE = SIG1+RATX*(SIG2-SIG1)
24536             ENDIF
24537          ENDIF
24538       ENDIF
24539
24540       RETURN
24541       END
24542
24543 *$ CREATE DT_XSTABL.FOR
24544 *COPY DT_XSTABL
24545 *
24546 *===xstabl=============================================================*
24547 *
24548       SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24549
24550       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24551       SAVE
24552
24553       PARAMETER ( LINP = 10 ,
24554      &            LOUT = 6 ,
24555      &            LDAT = 9 )
24556
24557       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24558      &           OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24559       LOGICAL LLAB,LELOG,LQLOG
24560
24561 * particle properties (BAMJET index convention)
24562       CHARACTER*8  ANAME
24563       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24564      &                IICH(210),IIBAR(210),K1(210),K2(210)
24565
24566 * properties of interacting particles
24567       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24568
24569       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24570
24571 * Glauber formalism: cross sections
24572       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24573      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24574      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24575      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24576      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24577      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24578      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24579      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24580      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24581      &                BSLOPE,NEBINI,NQBINI
24582
24583 * emulsion treatment
24584       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24585      &                NCOMPO,IEMUL
24586
24587       DIMENSION WHAT(6)
24588
24589       LLAB   = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24590       ELO    = ABS(WHAT(1))
24591       EHI    = ABS(WHAT(2))
24592       IF (ELO.GT.EHI) ELO = EHI
24593       LELOG  = WHAT(3).LT.ZERO
24594       NEBINS = MAX(INT(ABS(WHAT(3))),1)
24595       DEBINS = (EHI-ELO)/DBLE(NEBINS)
24596       IF (LELOG) THEN
24597          AELO   = LOG10(ELO)
24598          AEHI   = LOG10(EHI)
24599          ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24600       ENDIF
24601       Q2LO   = WHAT(4)
24602       Q2HI   = WHAT(5)
24603       IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24604       LQLOG  = WHAT(6).LT.ZERO
24605       NQBINS = MAX(INT(ABS(WHAT(6))),1)
24606       DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24607       IF (LQLOG) THEN
24608          AQ2LO  = LOG10(Q2LO)
24609          AQ2HI  = LOG10(Q2HI)
24610          ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24611       ENDIF
24612
24613       IF ( ELO.EQ. EHI) NEBINS = 0
24614       IF (Q2LO.EQ.Q2HI) NQBINS = 0
24615
24616       WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24617  1000 FORMAT(/,1X,'XSTABL:  E_lo  =',E10.3,' GeV  E_hi  =',E10.3,
24618      &       ' GeV     Lab = ',L1,'  qel: ',I2,/,10X,'Q2_lo =',F10.5,
24619      &       ' GeV^2  Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24620      &       '   A_p = ',I3,'   A_t = ',I3,/)
24621
24622 C     IF (IJPROJ.NE.7) THEN
24623          WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24624 * normalize fractions of emulsion components
24625          IF (NCOMPO.GT.0) THEN
24626             SUMFRA = ZERO
24627             DO 10 I=1,NCOMPO
24628                SUMFRA = SUMFRA+EMUFRA(I)
24629    10       CONTINUE
24630             IF (SUMFRA.GT.ZERO) THEN
24631                DO 11 I=1,NCOMPO
24632                   EMUFRA(I) = EMUFRA(I)/SUMFRA
24633    11          CONTINUE
24634             ENDIF
24635          ENDIF
24636 C     ELSE
24637 C        WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24638 C     ENDIF
24639       DO 1 I=1,NEBINS+1
24640          IF (LELOG) THEN
24641             E = 10**(AELO+DBLE(I-1)*ADEBIN)
24642          ELSE
24643             E = ELO+DBLE(I-1)*DEBINS
24644          ENDIF
24645          DO 2 J=1,NQBINS+1
24646             IF (LQLOG) THEN
24647                Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24648             ELSE
24649                Q2 = Q2LO+DBLE(J-1)*DQBINS
24650             ENDIF
24651 c            IF (IJPROJ.NE.7) THEN
24652                IF (LLAB) THEN
24653                   PLAB = ZERO
24654                   ECM  = ZERO
24655                   CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24656                ELSE
24657                   ECM = E
24658                ENDIF
24659                XI  = ZERO
24660                Q2I = ZERO
24661                IF (IJPROJ.EQ.7) Q2I = Q2
24662                IF (NCOMPO.GT.0) THEN
24663                   DO 20 IC=1,NCOMPO
24664                      IIT = IEMUMA(IC)
24665                      CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24666    20             CONTINUE
24667                ELSE
24668                   CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24669 C                 CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24670                ENDIF
24671                IF (NCOMPO.GT.0) THEN
24672                   XTOT = ZERO
24673                   ETOT = ZERO
24674                   XELA = ZERO
24675                   EELA = ZERO
24676                   XQEP = ZERO
24677                   EQEP = ZERO
24678                   XQET = ZERO
24679                   EQET = ZERO
24680                   XQE2 = ZERO
24681                   EQE2 = ZERO
24682                   XPRO = ZERO
24683                   EPRO = ZERO
24684                   XPRO1= ZERO
24685                   XDEL = ZERO
24686                   EDEL = ZERO
24687                   XDQE = ZERO
24688                   EDQE = ZERO
24689                   DO 21 IC=1,NCOMPO
24690                      XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
24691                      ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
24692                      XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
24693                      EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
24694                      XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
24695                      EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
24696                      XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
24697                      EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
24698                      XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
24699                      EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
24700                      XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
24701                      EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
24702                      XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
24703                      EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
24704                      XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
24705                      EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
24706                      YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
24707      &                     -XSQEP(1,1,IC)-XSQET(1,1,IC)
24708      &                     -XSQE2(1,1,IC)
24709                      XPRO1= XPRO1+EMUFRA(IC)*YPRO
24710    21             CONTINUE
24711                   ETOT = SQRT(ETOT)
24712                   EELA = SQRT(EELA)
24713                   EQEP = SQRT(EQEP)
24714                   EQET = SQRT(EQET)
24715                   EQE2 = SQRT(EQE2)
24716                   EPRO = SQRT(EPRO)
24717                   EDEL = SQRT(EDEL)
24718                   EDQE = SQRT(EDQE)
24719                   WRITE(LOUT,'(8E9.3)')
24720      &               E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
24721 C                 WRITE(LOUT,'(4E9.3)')
24722 C    &               E,XDEL,XDQE,XDEL+XDQE
24723                ELSE
24724                   WRITE(LOUT,'(11E10.3)')
24725      &              E,
24726      &              XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
24727      &              XSQE2(1,1,1),XSPRO(1,1,1),
24728      &              XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
24729      &             -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
24730      &              XSDEL(1,1,1)+XSDQE(1,1,1)
24731 C                 WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
24732 C    &                                    XSDEL(1,1,1)+XSDQE(1,1,1)
24733                ENDIF
24734 c            ELSE
24735 c               IF (LLAB) THEN
24736 c                  IF (IT.GT.1) THEN
24737 c                     IF (IXSQEL.EQ.0) THEN
24738 cC                       CALL DT_SIGGA(IT,  Q2, E,ZERO,ZERO,
24739 cC                       CALL DT_SIGGA(IT,   E,Q2,ZERO,ZERO,
24740 c                        CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
24741 c     &                             STOT,ETOT,SIN,EIN,STOT0)
24742 c                        IF (IRATIO.EQ.1) THEN
24743 c                           CALL DT_SIGGP(  Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
24744 cC                          CALL DT_SIGGP(   E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
24745 cC                          CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
24746 c*!! save cross sections
24747 c                           STOTA = STOT
24748 c                           ETOTA = ETOT
24749 c                           STOTP = STGP
24750 c*!!
24751 c                           STOT  = STOT/(DBLE(IT)*STGP)
24752 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
24753 c                           STOT0 = STGP
24754 c                           ETOT  = ZERO
24755 c                           EIN   = ZERO
24756 c                        ENDIF
24757 c                     ELSE
24758 c                        WRITE(LOUT,*)
24759 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
24760 c                        STOP
24761 c                     ENDIF
24762 c                  ELSE
24763 c                     ETOT = ZERO
24764 c                     EIN  = ZERO
24765 c                     STOT0= ZERO
24766 c                     IF (IXSQEL.EQ.0) THEN
24767 c                        CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
24768 c                     ELSE
24769 c                       SIN = ZERO
24770 c                       CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
24771 c                     ENDIF
24772 c                  ENDIF
24773 c               ELSE
24774 c                  IF (IT.GT.1) THEN
24775 c                     IF (IXSQEL.EQ.0) THEN
24776 c                        CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
24777 c     &                             STOT,ETOT,SIN,EIN,STOT0)
24778 c                        IF (IRATIO.EQ.1) THEN
24779 c                           CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
24780 c*!! save cross sections
24781 c                           STOTA = STOT
24782 c                           ETOTA = ETOT
24783 c                           STOTP = STGP
24784 c*!!
24785 c                           STOT  = STOT/(DBLE(IT)*STGP)
24786 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
24787 c                           STOT0 = STGP
24788 c                           ETOT  = ZERO
24789 c                           EIN   = ZERO
24790 c                        ENDIF
24791 c                     ELSE
24792 c                        WRITE(LOUT,*)
24793 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
24794 c                        STOP
24795 c                     ENDIF
24796 c                  ELSE
24797 c                     ETOT = ZERO
24798 c                     EIN  = ZERO
24799 c                     STOT0= ZERO
24800 c                     IF (IXSQEL.EQ.0) THEN
24801 c                        CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
24802 c                     ELSE
24803 c                       SIN = ZERO
24804 c                       CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
24805 c                     ENDIF
24806 c                  ENDIF
24807 c               ENDIF
24808 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
24809 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
24810 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
24811 c               WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
24812 c            ENDIF
24813     2    CONTINUE
24814     1 CONTINUE
24815
24816       RETURN
24817       END
24818
24819 *$ CREATE DT_TESTXS.FOR
24820 *COPY DT_TESTXS
24821 *
24822 *===testxs=============================================================*
24823 *
24824       SUBROUTINE DT_TESTXS
24825
24826       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24827       SAVE
24828
24829       DIMENSION XSTOT(26,2),XSELA(26,2)
24830
24831       OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
24832       OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
24833       OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
24834       OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
24835       DUMECM = 0.0D0
24836       PLABL = 0.01D0
24837       PLABH = 10000.0D0
24838       NBINS = 120
24839       APLABL = LOG10(PLABL)
24840       APLABH = LOG10(PLABH)
24841       ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
24842       DO 1 I=1,NBINS+1
24843          ADP = APLABL+DBLE(I-1)*ADPLAB
24844          P = 10.0D0**ADP
24845          DO 2 J=1,26
24846             CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
24847             CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
24848     2    CONTINUE
24849          WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
24850          WRITE(11,1000) P,(XSELA(K,1),K=1,26)
24851          WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
24852          WRITE(13,1000) P,(XSELA(K,2),K=1,26)
24853     1 CONTINUE
24854  1000 FORMAT(F8.3,26F9.3)
24855
24856       RETURN
24857       END
24858 ************************************************************************
24859 *                                                                      *
24860 *  DTUNUC 2.0:   library routines                                      *
24861 *                                   processed by S. Roesler, 6.5.95    *
24862 *                                                                      *
24863 ************************************************************************
24864 *
24865 *     1) Handling of parton momenta
24866 *          SUBROUTINE MASHEL
24867 *          SUBROUTINE DFERMI
24868 *
24869 *     2) Handling of parton flavors and particle indices
24870 *          INTEGER FUNCTION IPDG2B
24871 *          INTEGER FUNCTION IB2PDG
24872 *          INTEGER FUNCTION IQUARK
24873 *          INTEGER FUNCTION IBJQUA
24874 *          INTEGER FUNCTION ICIHAD
24875 *          INTEGER FUNCTION IPDGHA
24876 *          INTEGER FUNCTION MCHAD
24877 *          SUBROUTINE FLAHAD
24878 *
24879 *     3) Energy-momentum and quantum number conservation check routines
24880 *          SUBROUTINE EMC1
24881 *          SUBROUTINE EMC2
24882 *          SUBROUTINE EVTEMC
24883 *          SUBROUTINE EVTFLC
24884 *          SUBROUTINE EVTCHG
24885 *
24886 *     4) Transformations
24887 *          SUBROUTINE LTINI
24888 *          SUBROUTINE LTRANS
24889 *          SUBROUTINE LTNUC
24890 *          SUBROUTINE DALTRA
24891 *          SUBROUTINE DTRAFO
24892 *          SUBROUTINE STTRAN
24893 *          SUBROUTINE MYTRAN
24894 *          SUBROUTINE LT2LAO
24895 *          SUBROUTINE LT2LAB
24896 *
24897 *     5) Sampling from distributions
24898 *          INTEGER FUNCTION NPOISS
24899 *          DOUBLE PRECISION FUNCTION SAMPXB
24900 *          DOUBLE PRECISION FUNCTION SAMPEX
24901 *          DOUBLE PRECISION FUNCTION SAMSQX
24902 *          DOUBLE PRECISION FUNCTION BETREJ
24903 *          DOUBLE PRECISION FUNCTION DGAMRN
24904 *          DOUBLE PRECISION FUNCTION DBETAR
24905 *          SUBROUTINE RANNOR
24906 *          SUBROUTINE DPOLI
24907 *          SUBROUTINE DSFECF
24908 *          SUBROUTINE RACO
24909 *
24910 *     6) Special functions, algorithms and service routines
24911 *          DOUBLE PRECISION FUNCTION YLAMB
24912 *          SUBROUTINE SORT
24913 *          SUBROUTINE SORT1
24914 *          SUBROUTINE DT_XTIME
24915 *
24916 *     7) Random number generator package
24917 *          DOUBLE PRECISION FUNCTION DT_RNDM
24918 *          SUBROUTINE DT_RNDMST
24919 *          SUBROUTINE DT_RNDMIN
24920 *          SUBROUTINE DT_RNDMOU
24921 *          SUBROUTINE DT_RNDMTE
24922 *
24923 ************************************************************************
24924 *                                                                      *
24925 *                 1) Handling of parton momenta                        *
24926 *                                                                      *
24927 ************************************************************************
24928 *$ CREATE DT_MASHEL.FOR
24929 *COPY DT_MASHEL
24930 *
24931 *===mashel=============================================================*
24932 *
24933       SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
24934
24935 ************************************************************************
24936 *                                                                      *
24937 *    rescaling of momenta of two partons to put both                   *
24938 *                                       on mass shell                  *
24939 *                                                                      *
24940 *    input:       PA1,PA2   input momentum vectors                     *
24941 *                 XM1,2     desired masses of particles afterwards     *
24942 *                 P1,P2     changed momentum vectors                   *
24943 *                                                                      *
24944 * The original version is written by R. Engel.                         *
24945 * This version dated 12.12.94 is modified by S. Roesler.               *
24946 ************************************************************************
24947
24948       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24949       SAVE
24950
24951       PARAMETER ( LINP = 10 ,
24952      &            LOUT = 6 ,
24953      &            LDAT = 9 )
24954
24955       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
24956
24957       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
24958
24959       IREJ = 0
24960
24961 * Lorentz transformation into system CMS
24962       PX  = PA1(1)+PA2(1)
24963       PY  = PA1(2)+PA2(2)
24964       PZ  = PA1(3)+PA2(3)
24965       EE  = PA1(4)+PA2(4)
24966       XPTOT = SQRT(PX**2+PY**2+PZ**2)
24967       XMS   = (EE-XPTOT)*(EE+XPTOT)
24968       IF(XMS.LT.(XM1+XM2)**2) THEN
24969 C        WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
24970          GOTO 9999
24971       ENDIF
24972       XMS = SQRT(XMS)
24973       BGX = PX/XMS
24974       BGY = PY/XMS
24975       BGZ = PZ/XMS
24976       GAM = EE/XMS
24977       CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
24978      &           PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
24979 * rotation angles
24980       COD = P1(3)/PTOT1
24981 C     SID = SQRT((ONE-COD)*(ONE+COD))
24982       PPT = SQRT(P1(1)**2+P1(2)**2)
24983       SID = PPT/PTOT1
24984       COF = ONE
24985       SIF = ZERO
24986       IF(PTOT1*SID.GT.TINY10) THEN
24987          COF   = P1(1)/(SID*PTOT1)
24988          SIF   = P1(2)/(SID*PTOT1)
24989          ANORF = SQRT(COF*COF+SIF*SIF)
24990          COF   = COF/ANORF
24991          SIF   = SIF/ANORF
24992       ENDIF
24993 * new CM momentum and energies (for masses XM1,XM2)
24994       XM12 = SIGN(XM1**2,XM1)
24995       XM22 = SIGN(XM2**2,XM2)
24996       SS   = XMS**2
24997       PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
24998       EE1  = SQRT(XM12+PCMP**2)
24999       EE2  = XMS-EE1
25000 * back rotation
25001       MODE = 1
25002       CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
25003       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
25004      &            PTOT1,P1(1),P1(2),P1(3),P1(4))
25005       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25006      &            PTOT2,P2(1),P2(2),P2(3),P2(4))
25007 * check consistency
25008       DEL = XMS*0.0001D0
25009       IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25010         IDEV = 1
25011       ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25012         IDEV = 2
25013       ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25014         IDEV = 3
25015       ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25016         IDEV = 4
25017       ELSE
25018         IDEV = 0
25019       ENDIF
25020       IF (IDEV.NE.0) THEN
25021          WRITE(LOUT,'(/1X,A,I3)')
25022      &      'MASHEL: inconsistent transformation',IDEV
25023          WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25024          WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25025          WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25026          WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25027          WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25028          WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25029       ENDIF
25030       RETURN
25031
25032  9999 CONTINUE
25033       IREJ = 1
25034       RETURN
25035       END
25036
25037 *$ CREATE DT_DFERMI.FOR
25038 *COPY DT_DFERMI
25039 *
25040 *===dfermi=============================================================*
25041 *
25042       SUBROUTINE DT_DFERMI(GPART)
25043
25044 ************************************************************************
25045 * Find largest of three random numbers.                                *
25046 ************************************************************************
25047
25048       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25049       SAVE
25050
25051       DIMENSION G(3)
25052
25053       DO 10 I=1,3
25054         G(I)=DT_RNDM(GPART)
25055    10 CONTINUE
25056       IF (G(3).LT.G(2)) GOTO 40
25057       IF (G(3).LT.G(1)) GOTO 30
25058       GPART = G(3)
25059    20 RETURN
25060    30 GPART = G(1)
25061       GOTO 20
25062    40 IF (G(2).LT.G(1)) GOTO 30
25063       GPART = G(2)
25064       GOTO 20
25065
25066       END
25067
25068 ************************************************************************
25069 *                                                                      *
25070 *         2) Handling of parton flavors and particle indices           *
25071 *                                                                      *
25072 ************************************************************************
25073 *$ CREATE IDT_IPDG2B.FOR
25074 *COPY IDT_IPDG2B
25075 *
25076 *===ipdg2b=============================================================*
25077 *
25078       INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25079
25080 ************************************************************************
25081 *                                                                      *
25082 *     conversion of quark numbering scheme                             *
25083 *                                                                      *
25084 *     input:   PDG parton numbering                                    *
25085 *              for diquarks:  NN number of the constituent quark       *
25086 *                             (e.g. ID=2301,NN=1 -> ICONV2=1)          *
25087 *                                                                      *
25088 *     output:  BAMJET particle codes                                   *
25089 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25090 *              2 d     8 a-d             -2 a-d                        *
25091 *              3 s     9 a-s             -3 a-s                        *
25092 *              4 c    10 a-c             -4 a-c                        *
25093 *                                                                      *
25094 * This is a modified version of ICONV2 written by R. Engel.            *
25095 * This version dated 13.12.94 is written by S. Roesler.                *
25096 ************************************************************************
25097
25098       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25099       SAVE
25100
25101       PARAMETER ( LINP = 10 ,
25102      &            LOUT = 6 ,
25103      &            LDAT = 9 )
25104
25105       IDA = ABS(ID)
25106 * diquarks
25107       IF (IDA.GT.6) THEN
25108         KF  = 3
25109         IF (IDA.GE.1000) KF = 4
25110         IDA = IDA/(10**(KF-NN))
25111         IDA = MOD(IDA,10)
25112       ENDIF
25113 * exchange up and dn quarks
25114       IF (IDA.EQ.1) THEN
25115         IDA = 2
25116       ELSEIF (IDA.EQ.2) THEN
25117         IDA = 1
25118       ENDIF
25119 * antiquarks
25120       IF (ID.LT.0) THEN
25121          IF (MODE.EQ.1) THEN
25122             IDA = IDA+6
25123          ELSE
25124             IDA = -IDA
25125          ENDIF
25126       ENDIF
25127       IDT_IPDG2B = IDA
25128
25129       RETURN
25130       END
25131
25132 *$ CREATE IDT_IB2PDG.FOR
25133 *COPY IDT_IB2PDG
25134 *
25135 *===ib2pdg=============================================================*
25136 *
25137       INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25138
25139 ************************************************************************
25140 *                                                                      *
25141 *     conversion of quark numbering scheme                             *
25142 *                                                                      *
25143 *     input:   BAMJET particle codes                                   *
25144 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25145 *              2 d     8 a-d             -2 a-d                        *
25146 *              3 s     9 a-s             -3 a-s                        *
25147 *              4 c    10 a-c             -4 a-c                        *
25148 *                                                                      *
25149 *     output:  PDG parton numbering                                    *
25150 *                                                                      *
25151 * This version dated 13.12.94 is written by S. Roesler.                *
25152 ************************************************************************
25153
25154       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25155       SAVE
25156
25157       PARAMETER ( LINP = 10 ,
25158      &            LOUT = 6 ,
25159      &            LDAT = 9 )
25160
25161       DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25162       DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25163       DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25164      &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25165      &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25166
25167       IDA = ID1
25168       IDB = ID2
25169       IF (MODE.EQ.1) THEN
25170          IF (ID1.GT.6) IDA = -(ID1-6)
25171          IF (ID2.GT.6) IDB = -(ID2-6)
25172       ENDIF
25173       IF (ID2.EQ.0) THEN
25174          IDT_IB2PDG = IHKKQ(IDA)
25175       ELSE
25176          IDT_IB2PDG = IHKKQQ(IDA,IDB)
25177       ENDIF
25178
25179       RETURN
25180       END
25181
25182 *$ CREATE IDT_IQUARK.FOR
25183 *COPY IDT_IQUARK
25184 *
25185 *===ipdgqu=============================================================*
25186 *
25187       INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25188
25189 ************************************************************************
25190 *                                                                      *
25191 *     quark contents according to PDG conventions                      *
25192 *     (random selection in case of quark mixing)                       *
25193 *                                                                      *
25194 *     input:   IDBAMJ BAMJET particle code                             *
25195 *              K      1..3   quark number                              *
25196 *                                                                      *
25197 *     output:  1   d  (anti --> neg.)                                  *
25198 *              2   u                                                   *
25199 *              3   s                                                   *
25200 *              4   c                                                   *
25201 *                                                                      *
25202 * This version written by R. Engel.                                    *
25203 ************************************************************************
25204
25205       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25206       SAVE
25207
25208       IQ = IDT_IBJQUA(K,IDBAMJ)
25209 * quark-antiquark
25210       IF (IQ.GT.6) THEN
25211          IQ = 6-IQ
25212       ENDIF
25213 * exchange of up and down
25214       IF (ABS(IQ).EQ.1) THEN
25215          IQ = SIGN(2,IQ)
25216       ELSEIF (ABS(IQ).EQ.2) THEN
25217          IQ = SIGN(1,IQ)
25218       ENDIF
25219       IDT_IQUARK = IQ
25220
25221       RETURN
25222       END
25223
25224 *$ CREATE IDT_IBJQUA.FOR
25225 *COPY IDT_IBJQUA
25226 *
25227 *===ibamq==============================================================*
25228 *
25229       INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25230
25231 ************************************************************************
25232 *                                                                      *
25233 *     quark contents according to BAMJET conventions                   *
25234 *     (random selection in case of quark mixing)                       *
25235 *                                                                      *
25236 *     input:   IDBAMJ BAMJET particle code                             *
25237 *              K      1..3   quark number                              *
25238 *                                                                      *
25239 *     output:  1   u      7   u bar                                    *
25240 *              2   d      8   d bar                                    *
25241 *              3   s      9   s bar                                    *
25242 *              4   c     10   c bar                                    *
25243 *                                                                      *
25244 * This version written by R. Engel.                                    *
25245 ************************************************************************
25246
25247       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25248       SAVE
25249
25250       DIMENSION ITAB(3,210)
25251       DATA ((ITAB(I,K),I=1,3),K=1,30) /
25252      &    1,  1,  2,   7,  7,  8,   0,  0,  0,
25253      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25254      &    0,  0,  0,   1,  2,  2,   7,  8,  8,
25255 *sr 10.1.94
25256 C    &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25257      &    0,  0,  0,   0,  0,  0,   3,  8,  0,
25258 *
25259      &    1,  8,  0,   2,  7,  0,   1,  9,  0,
25260 *sr 10.1.94
25261 C    &    3,  7,  0,   0,  0,  0,   0,  0,  0,
25262      &    3,  7,  0,   3,  1,  2,   9,  7,  8,
25263 *sr 10.1.94
25264 C    &    0,  0,  0,   2,  2,  3,   1,  1,  3,
25265      &    2,  9,  0,   2,  2,  3,   1,  1,  3,
25266 *
25267      &    1,  2,  3, 201,202,  0,   2,  9,  0,
25268      &    3,  8,  0,   0,  0,  0,   0,  0,  0,
25269      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25270       DATA ((ITAB(I,K),I=1,3),K=31,60) /
25271      &    3,  9,  0,   1,  8,  0, 203,204,  0,
25272      &    2,  7,  0,   0,  0,  0,   1,  9,  0,
25273      &    2,  9,  0,   3,  7,  0,   3,  8,  0,
25274      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25275      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25276      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25277      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25278      &    0,  0,  0,   1,  1,  1,   1,  1,  2,
25279      &    1,  2,  2,   2,  2,  2,   0,  0,  0,
25280      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25281       DATA ((ITAB(I,K),I=1,3),K=61,90) /
25282      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25283      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25284      &    7,  7,  7,   7,  7,  8,   7,  8,  8,
25285      &    8,  8,  8,   0,  0,  0,   0,  0,  0,
25286      &    0,  0,  0,   0,  0,  0,   0,  0,  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,   0,  0,  0,   0,  0,  0,
25290      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25291      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25292       DATA ((ITAB(I,K),I=1,3),K=91,120) /
25293      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25294      &    0,  0,  0,   0,  0,  0,   3,  9,  0,
25295      &    1,  3,  3,   2,  3,  3,   7,  7,  9,
25296      &    7,  8,  9,   8,  8,  9,   7,  9,  9,
25297      &    8,  9,  9,   1,  1,  3,   1,  2,  3,
25298      &    2,  2,  3,   1,  3,  3,   2,  3,  3,
25299      &    3,  3,  3,   7,  7,  9,   7,  8,  9,
25300      &    8,  8,  9,   7,  9,  9,   8,  9,  9,
25301      &    9,  9,  9,   4,  7,  0,   4,  8,  0,
25302      &    2, 10,  0,   1, 10,  0,   4,  9,  0 /
25303       DATA ((ITAB(I,K),I=1,3),K=121,150) /
25304      &    3, 10,  0,   4, 10,  0,   4,  7,  0,
25305      &    4,  8,  0,   2, 10,  0,   1, 10,  0,
25306      &    4,  9,  0,   3, 10,  0,   4, 10,  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,   1,  2,  4,   1,  3,  4,
25310      &    2,  3,  4,   1,  1,  4,   0,  0,  0,
25311      &    2,  2,  4,   0,  0,  0,   0,  0,  0,
25312      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25313      &    3,  4,  4,   7,  8, 10,   7,  9, 10 /
25314       DATA ((ITAB(I,K),I=1,3),K=151,180) /
25315      &    8,  9, 10,   7,  7, 10,   0,  0,  0,
25316      &    8,  8, 10,   0,  0,  0,   0,  0,  0,
25317      &    9,  9, 10,   7, 10, 10,   8, 10, 10,
25318      &    9, 10, 10,   1,  1,  4,   1,  2,  4,
25319      &    2,  2,  4,   1,  3,  4,   2,  3,  4,
25320      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25321      &    3,  4,  4,   4,  4,  4,   7,  7, 10,
25322      &    7,  8, 10,   8,  8, 10,   7,  9, 10,
25323      &    8,  9, 10,   9,  9, 10,   7, 10, 10,
25324      &    8, 10, 10,   9, 10, 10,  10, 10, 10 /
25325       DATA ((ITAB(I,K),I=1,3),K=181,210) /
25326      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25327      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25328      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25329      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25330      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25331      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25332      &    0,  0,  0,   0,  0,  0,   1,  7,  0,
25333      &    2,  8,  0,   1,  7,  0,   2,  8,  0,
25334      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25335      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25336       DATA IDOLD /0/
25337
25338       ONE = 1.0D0
25339       IF (ITAB(1,IDBAMJ).LE.200) THEN
25340          ID = ITAB(K,IDBAMJ)
25341       ELSE
25342          IF(IDOLD.NE.IDBAMJ) THEN
25343             IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25344      &           DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25345         ELSE
25346            IDOLD = 0
25347         ENDIF
25348         ID = ITAB(K,IT)
25349       ENDIF
25350       IDOLD  = IDBAMJ
25351       IDT_IBJQUA = ID
25352
25353       RETURN
25354       END
25355
25356 *$ CREATE IDT_ICIHAD.FOR
25357 *COPY IDT_ICIHAD
25358 *
25359 *===icihad=============================================================*
25360 *
25361       INTEGER FUNCTION IDT_ICIHAD(MCIND)
25362
25363 ************************************************************************
25364 * Conversion of particle index PDG proposal --> BAMJET-index scheme    *
25365 * This is a completely new version dated 25.10.95.                     *
25366 * Renamed to be not in conflict with the modified PHOJET-version       *
25367 ************************************************************************
25368
25369       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25370       SAVE
25371
25372 * hadron index conversion (BAMJET <--> PDG)
25373       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25374      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25375      &                IAMCIN(210)
25376
25377       IDT_ICIHAD = 0
25378       KPDG   = ABS(MCIND)
25379       IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25380       IF (MCIND.LT.0) THEN
25381          JSIGN = 1
25382       ELSE
25383          JSIGN = 2
25384       ENDIF
25385       IF (KPDG.GE.10000) THEN
25386          DO 1 I=1,19
25387             IDT_ICIHAD = IBAM5(JSIGN,I)
25388             IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25389             IDT_ICIHAD = 0
25390     1    CONTINUE
25391       ELSEIF (KPDG.GE.1000) THEN
25392          DO 2 I=1,29
25393             IDT_ICIHAD = IBAM4(JSIGN,I)
25394             IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25395             IDT_ICIHAD = 0
25396     2    CONTINUE
25397       ELSEIF (KPDG.GE.100) THEN
25398          DO 3 I=1,22
25399             IDT_ICIHAD = IBAM3(JSIGN,I)
25400             IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25401             IDT_ICIHAD = 0
25402     3    CONTINUE
25403       ELSEIF (KPDG.GE.10) THEN
25404          DO 4 I=1,7
25405             IDT_ICIHAD = IBAM2(JSIGN,I)
25406             IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25407             IDT_ICIHAD = 0
25408     4    CONTINUE
25409       ENDIF
25410     5 CONTINUE
25411
25412       RETURN
25413       END
25414
25415 *$ CREATE IDT_IPDGHA.FOR
25416 *COPY IDT_IPDGHA
25417 *
25418 *===ipdgha=============================================================*
25419 *
25420       INTEGER FUNCTION IDT_IPDGHA(MCIND)
25421
25422 ************************************************************************
25423 * Conversion of particle index BAMJET-index scheme --> PDG proposal    *
25424 * Adopted from the original by S. Roesler. This version dated 12.5.95  *
25425 * Renamed to be not in conflict with the modified PHOJET-version       *
25426 ************************************************************************
25427
25428       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25429       SAVE
25430
25431 * hadron index conversion (BAMJET <--> PDG)
25432       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25433      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25434      &                IAMCIN(210)
25435
25436       IDT_IPDGHA = IAMCIN(MCIND)
25437
25438       RETURN
25439       END
25440
25441 *$ CREATE DT_FLAHAD.FOR
25442 *COPY DT_FLAHAD
25443 *
25444 *===flahad=============================================================*
25445 *
25446       SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25447
25448 ************************************************************************
25449 * sampling of FLAvor composition for HADrons/photons                   *
25450 *              ID         BAMJET-id of hadron                          *
25451 *              IF1,2,3    flavor content                               *
25452 *                         (u,d,s: 1,2,3;  au,ad,as: -1,-1,-3)          *
25453 * Note:  -  u,d numbering as in BAMJET                                 *
25454 *        -  ID .le. 30 !!                                              *
25455 * This version dated 12.03.96 is written by S. Roesler                 *
25456 ************************************************************************
25457
25458       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25459       SAVE
25460
25461 * auxiliary common for reggeon exchange (DTUNUC 1.x)
25462       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25463      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25464      &                IQTCHR(-6:6),MQUARK(3,39)
25465
25466       DIMENSION JSEL(3,6)
25467       DATA JSEL/ 1,2,3,  2,3,1,  3,1,2,  1,3,2,   2,1,3,   3,2,1/
25468
25469       ONE = 1.0D0
25470       IF (ID.EQ.7) THEN
25471 * photon (charge dependent flavour sampling)
25472          K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25473          IF (K.LE.4) THEN
25474             IF1 = 2
25475             IF2 = -2
25476          ELSE IF(K.EQ.5) THEN
25477             IF1 = 1
25478             IF2 = -1
25479          ELSE
25480             IF1 = 3
25481             IF2 = -3
25482          ENDIF
25483          IF(DT_RNDM(ONE).LT.0.5D0) THEN
25484             K   = IF1
25485             IF1 = IF2
25486             IF2 = K
25487          ENDIF
25488          IF3 = 0
25489       ELSE
25490 * hadron
25491          IX  = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25492          IF1 = MQUARK(JSEL(1,IX),ID)
25493          IF2 = MQUARK(JSEL(2,IX),ID)
25494          IF3 = MQUARK(JSEL(3,IX),ID)
25495          IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25496             IF1 = IF3
25497             IF3 = 0
25498          ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25499             IF2 = IF3
25500             IF3 = 0
25501          ENDIF
25502       ENDIF
25503
25504       RETURN
25505       END
25506
25507 *$ CREATE IDT_MCHAD.FOR
25508 *COPY IDT_MCHAD
25509 *
25510 *===mchad==============================================================*
25511 *
25512       INTEGER FUNCTION IDT_MCHAD(ITDTU)
25513
25514 ************************************************************************
25515 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25516 * Adopted from the original by S. Roesler. This version dated 6.5.95   *
25517 *                                                                      *
25518 * Last change 28.12.2006 by S. Roesler.                                *
25519 ************************************************************************
25520
25521       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25522       SAVE
25523
25524       DIMENSION ITRANS(210)
25525       DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25526      &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25527      &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25528      &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25529      &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25530      &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25531      &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25532
25533       IF ( ITDTU .GT. 0 ) THEN
25534          IDT_MCHAD = ITRANS(ITDTU)
25535       ELSE
25536          IDT_MCHAD = -1
25537       END IF
25538
25539       RETURN
25540       END
25541
25542 ************************************************************************
25543 *                                                                      *
25544 *   3) Energy-momentum and quantum number conservation check routines  *
25545 *                                                                      *
25546 ************************************************************************
25547 *$ CREATE DT_EMC1.FOR
25548 *COPY DT_EMC1
25549 *
25550 *===emc1===============================================================*
25551 *
25552       SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25553
25554 ************************************************************************
25555 * This version dated 15.12.94 is written by S. Roesler                 *
25556 ************************************************************************
25557
25558       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25559       SAVE
25560
25561       PARAMETER ( LINP = 10 ,
25562      &            LOUT = 6 ,
25563      &            LDAT = 9 )
25564
25565       PARAMETER (TINY10=1.0D-10)
25566
25567       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25568
25569       IREJ = 0
25570
25571       IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25572      &   WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25573
25574       IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25575          IF (MODE.EQ.1) THEN
25576             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25577          ELSEIF (MODE.EQ.2) THEN
25578             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25579          ENDIF
25580          CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25581          CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25582          CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25583       ELSEIF (MODE.LT.0) THEN
25584          IF (MODE.EQ.-1) THEN
25585             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25586          ELSEIF (MODE.EQ.-2) THEN
25587             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25588          ENDIF
25589          CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25590          CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25591          CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25592       ENDIF
25593
25594       IF (ABS(MODE).EQ.3) THEN
25595          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25596          IF (IREJ1.NE.0) GOTO 9999
25597       ENDIF
25598       RETURN
25599
25600  9999 CONTINUE
25601       IREJ = 1
25602       RETURN
25603       END
25604
25605 *$ CREATE DT_EMC2.FOR
25606 *COPY DT_EMC2
25607 *
25608 *===emc2===============================================================*
25609 *
25610       SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25611      &                                                MODE,IPOS,IREJ)
25612
25613 ************************************************************************
25614 *             MODE = 1   energy-momentum cons. check                   *
25615 *                  = 2   flavor-cons. check                            *
25616 *                  = 3   energy-momentum & flavor cons. check          *
25617 *                  = 4   energy-momentum & charge cons. check          *
25618 *                  = 5   energy-momentum & flavor & charge cons. check *
25619 * This version dated 16.01.95 is written by S. Roesler                 *
25620 ************************************************************************
25621
25622       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25623       SAVE
25624
25625       PARAMETER ( LINP = 10 ,
25626      &            LOUT = 6 ,
25627      &            LDAT = 9 )
25628
25629       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25630
25631 * event history
25632
25633       PARAMETER (NMXHKK=200000)
25634
25635       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25636      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25637      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25638
25639 * extended event history
25640       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25641      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25642      &                IHIST(2,NMXHKK)
25643
25644       IREJ  = 0
25645       IREJ1 = 0
25646       IREJ2 = 0
25647       IREJ3 = 0
25648
25649       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25650      &                CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25651       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25652      &                                CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25653       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25654       DO 1 I=1,NHKK
25655          IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25656      &       (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25657      &       (ISTHKK(I).EQ.IP5))                          THEN
25658             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25659      &                                    .OR.(MODE.EQ.5))
25660      &      CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25661      &                                               2,IDUM,IDUM)
25662             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25663      &         CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25664             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25665      &                            CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25666          ENDIF
25667          IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25668      &       (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25669      &       (ISTHKK(I).EQ.IN5))                          THEN
25670             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25671      &                                    .OR.(MODE.EQ.5))
25672      &      CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25673      &                                                   2,IDUM,IDUM)
25674             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25675      &         CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25676             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25677      &                            CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25678          ENDIF
25679     1 CONTINUE
25680       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25681      &   CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25682       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25683      &   CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25684       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25685       IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25686
25687       RETURN
25688
25689  9999 CONTINUE
25690       IREJ = 1
25691       RETURN
25692       END
25693
25694 *$ CREATE DT_EVTEMC.FOR
25695 *COPY DT_EVTEMC
25696 *
25697 *===evtemc=============================================================*
25698 *
25699       SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
25700
25701 ************************************************************************
25702 * This version dated 13.12.94 is written by S. Roesler                 *
25703 ************************************************************************
25704
25705       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25706       SAVE
25707
25708       PARAMETER ( LINP = 10 ,
25709      &            LOUT = 6 ,
25710      &            LDAT = 9 )
25711
25712       PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
25713      &           ZERO=0.0D0)
25714
25715 * event history
25716
25717       PARAMETER (NMXHKK=200000)
25718
25719       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25720      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25721      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25722
25723 * flags for input different options
25724       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
25725       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
25726      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
25727
25728       IREJ = 0
25729
25730       MODE = IMODE
25731       CHKLEV = TINY10
25732       IF (MODE.EQ.4) THEN
25733          CHKLEV = TINY2
25734          MODE   = 3
25735       ELSEIF (MODE.EQ.5) THEN
25736          CHKLEV = TINY1
25737          MODE   = 3
25738       ELSEIF (MODE.EQ.-1) THEN
25739          CHKLEV = EIO
25740          MODE   = 3
25741       ENDIF
25742
25743       IF (ABS(MODE).EQ.3) THEN
25744          PXDEV = PX
25745          PYDEV = PY
25746          PZDEV = PZ
25747          EDEV  = E
25748          IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
25749          IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
25750      &       (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
25751             IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
25752      &         'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
25753      &         '  event  ',NEVHKK,
25754      &         ' ! ',PXDEV,PYDEV,PZDEV,EDEV
25755             PX   = 0.0D0
25756             PY   = 0.0D0
25757             PZ   = 0.0D0
25758             E    = 0.0D0
25759             GOTO 9999
25760          ENDIF
25761          PX   = 0.0D0
25762          PY   = 0.0D0
25763          PZ   = 0.0D0
25764          E    = 0.0D0
25765          RETURN
25766       ENDIF
25767
25768       IF (MODE.EQ.1) THEN
25769          PX = 0.0D0
25770          PY = 0.0D0
25771          PZ = 0.0D0
25772          E  = 0.0D0
25773       ENDIF
25774
25775       PX = PX+PXIO
25776       PY = PY+PYIO
25777       PZ = PZ+PZIO
25778       E  = E+EIO
25779
25780       RETURN
25781
25782  9999 CONTINUE
25783       IREJ = 1
25784       RETURN
25785       END
25786
25787 *$ CREATE DT_EVTFLC.FOR
25788 *COPY DT_EVTFLC
25789 *
25790 *===evtflc=============================================================*
25791 *
25792       SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
25793
25794 ************************************************************************
25795 * Flavor conservation check.                                           *
25796 *        ID       identity of particle                                 *
25797 *        ID1 = 1  ID for q,aq,qq,aqaq in PDG-numbering scheme          *
25798 *            = 2  ID for particle/resonance in BAMJET numbering scheme *
25799 *            = 3  ID for particle/resonance in PDG    numbering scheme *
25800 *        MODE = 1 initialization and add ID                            *
25801 *             =-1 initialization and subtract ID                       *
25802 *             = 2 add ID                                               *
25803 *             =-2 subtract ID                                          *
25804 *             = 3 check flavor cons.                                   *
25805 *        IPOS     flag to give position of call of EVTFLC to output    *
25806 *                 unit in case of violation                            *
25807 * This version dated 10.01.95 is written by S. Roesler                 *
25808 ************************************************************************
25809
25810       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25811       SAVE
25812
25813       PARAMETER ( LINP = 10 ,
25814      &            LOUT = 6 ,
25815      &            LDAT = 9 )
25816
25817       PARAMETER (TINY10=1.0D-10)
25818
25819       IREJ = 0
25820
25821       IF (MODE.EQ.3) THEN
25822          IF (IFL.NE.0) THEN
25823             WRITE(LOUT,'(1X,A,I3,A,I3)')
25824      &         'EVTFLC: flavor-conservation failure at pos. ',IPOS,
25825      &         ' !  IFL = ',IFL
25826             IFL = 0
25827             GOTO 9999
25828          ENDIF
25829          IFL = 0
25830          RETURN
25831       ENDIF
25832
25833       IF (MODE.EQ.1) IFL = 0
25834       IF (ID.EQ.0)   RETURN
25835
25836       IF (ID1.EQ.1) THEN
25837          IDD = ABS(ID)
25838          NQ  = 1
25839          IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
25840          IF (IDD.GE.1000) NQ = 3
25841          DO 1 I=1,NQ
25842             IFBAM = IDT_IPDG2B(ID,I,2)
25843             IF (ABS(IFBAM).EQ.1) THEN
25844                IFBAM = SIGN(2,IFBAM)
25845             ELSEIF (ABS(IFBAM).EQ.2) THEN
25846                IFBAM = SIGN(1,IFBAM)
25847             ENDIF
25848             IF (MODE.GT.0) THEN
25849                IFL = IFL+IFBAM
25850             ELSE
25851                IFL = IFL-IFBAM
25852             ENDIF
25853     1    CONTINUE
25854          RETURN
25855       ENDIF
25856
25857       IDD = ID
25858       IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
25859       IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
25860          DO 2 I=1,3
25861             IF (MODE.GT.0) THEN
25862                IFL = IFL+IDT_IQUARK(I,IDD)
25863             ELSE
25864                IFL = IFL-IDT_IQUARK(I,IDD)
25865             ENDIF
25866     2    CONTINUE
25867       ENDIF
25868       RETURN
25869
25870  9999 CONTINUE
25871       IREJ = 1
25872       RETURN
25873       END
25874
25875 *$ CREATE DT_EVTCHG.FOR
25876 *COPY DT_EVTCHG
25877 *
25878 *===evtchg=============================================================*
25879 *
25880       SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
25881
25882 ************************************************************************
25883 * Charge conservation check.                                           *
25884 *        ID       identity of particle (PDG-numbering scheme)          *
25885 *        MODE = 1 initialization                                       *
25886 *             =-2 subtract ID-charge                                   *
25887 *             = 2 add ID-charge                                        *
25888 *             = 3 check charge cons.                                   *
25889 *        IPOS     flag to give position of call of EVTCHG to output    *
25890 *                 unit in case of violation                            *
25891 * This version dated 10.01.95 is written by S. Roesler                 *
25892 * Last change: s.r. 21.01.01                                           *
25893 ************************************************************************
25894
25895       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25896       SAVE
25897
25898       PARAMETER ( LINP = 10 ,
25899      &            LOUT = 6 ,
25900      &            LDAT = 9 )
25901
25902 * event history
25903
25904       PARAMETER (NMXHKK=200000)
25905
25906       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25907      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25908      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25909
25910 * particle properties (BAMJET index convention)
25911       CHARACTER*8  ANAME
25912       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
25913      &                IICH(210),IIBAR(210),K1(210),K2(210)
25914
25915       IREJ = 0
25916
25917       IF (MODE.EQ.1) THEN
25918          ICH  = 0
25919          IBAR = 0
25920          RETURN
25921       ENDIF
25922
25923       IF (MODE.EQ.3) THEN
25924          IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
25925             WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
25926      &         'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
25927      &         '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
25928             ICH  = 0
25929             IBAR = 0
25930             GOTO 9999
25931          ENDIF
25932          ICH  = 0
25933          IBAR = 0
25934          RETURN
25935       ENDIF
25936
25937       IF (ID.EQ.0)   RETURN
25938
25939       IDD = IDT_ICIHAD(ID)
25940 * modification 21.1.01: use intrinsic phojet-functions to determine charge
25941 * and baryon number
25942 C     IF (IDD.GT.0) THEN
25943 C        IF (MODE.EQ.2) THEN
25944 C           ICH  = ICH+IICH(IDD)
25945 C           IBAR = IBAR+IIBAR(IDD)
25946 C        ELSEIF (MODE.EQ.-2) THEN
25947 C           ICH  = ICH-IICH(IDD)
25948 C           IBAR = IBAR-IIBAR(IDD)
25949 C        ENDIF
25950 C     ELSE
25951 C        WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
25952 C        CALL DT_EVTOUT(4)
25953 C        STOP
25954 C     ENDIF
25955       IF (MODE.EQ.2) THEN
25956          ICH  = ICH+IPHO_CHR3(ID,1)/3
25957          IBAR = IBAR+IPHO_BAR3(ID,1)/3
25958       ELSEIF (MODE.EQ.-2) THEN
25959          ICH  = ICH-IPHO_CHR3(ID,1)/3
25960          IBAR = IBAR-IPHO_BAR3(ID,1)/3
25961       ENDIF
25962
25963       RETURN
25964
25965  9999 CONTINUE
25966       IREJ = 1
25967       RETURN
25968       END
25969
25970 ************************************************************************
25971 *                                                                      *
25972 *                 4) Transformations                                   *
25973 *                                                                      *
25974 ************************************************************************
25975 *$ CREATE DT_LTINI.FOR
25976 *COPY DT_LTINI
25977 *
25978 *===ltini==============================================================*
25979 *
25980       SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
25981
25982 ************************************************************************
25983 * Initializations of Lorentz-transformations, calculation of Lorentz-  *
25984 * parameters.                                                          *
25985 * This version dated 13.11.95 is written by  S. Roesler.               *
25986 ************************************************************************
25987
25988       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25989       SAVE
25990
25991       PARAMETER ( LINP = 10 ,
25992      &            LOUT = 6 ,
25993      &            LDAT = 9 )
25994
25995       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
25996      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
25997
25998 * Lorentz-parameters of the current interaction
25999       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26000      &                UMO,PPCM,EPROJ,PPROJ
26001
26002 * properties of photon/lepton projectiles
26003       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
26004
26005 * particle properties (BAMJET index convention)
26006       CHARACTER*8  ANAME
26007       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26008      &                IICH(210),IIBAR(210),K1(210),K2(210)
26009
26010 * nucleon-nucleon event-generator
26011       CHARACTER*8 CMODEL
26012       LOGICAL LPHOIN
26013       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26014
26015       Q2   = VIRT
26016       IDP  = IDPR
26017       IF (MCGENE.NE.3) THEN
26018 * lepton-projectiles and PHOJET: initialize real photon instead
26019          IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26020      &       (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26021      &       (IDPR.EQ. 5).OR.(IDPR.EQ. 6))   THEN
26022             IDP = 7
26023             Q2  = ZERO
26024          ENDIF
26025       ENDIF
26026       IDT  = IDTA
26027       EPN  = EPN0
26028       PPN  = PPN0
26029       ECM  = ECM0
26030       AMP  = AAM(IDP)-SQRT(ABS(Q2))
26031       AMT  = AAM(IDT)
26032       AMP2 = SIGN(AMP**2,AMP)
26033       AMT2 = AMT**2
26034       IF (ECM0.GT.ZERO) THEN
26035          EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26036          IF (AMP2.GT.ZERO) THEN
26037             PPN = SQRT((EPN+AMP)*(EPN-AMP))
26038          ELSE
26039             PPN = SQRT(EPN**2-AMP2)
26040          ENDIF
26041       ELSE
26042          IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26043             IF (IDP.EQ.7) EPN = ABS(EPN)
26044             IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26045             IF (AMP2.GT.ZERO) THEN
26046                PPN = SQRT((EPN+AMP)*(EPN-AMP))
26047             ELSE
26048                PPN = SQRT(EPN**2-AMP2)
26049             ENDIF
26050          ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26051             IF (AMP2.GT.ZERO) THEN
26052                EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26053             ELSE
26054                EPN = SQRT(PPN**2+AMP2)
26055             ENDIF
26056          ENDIF
26057          ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26058       ENDIF
26059       UMO   = ECM
26060       EPROJ = EPN
26061       PPROJ = PPN
26062       IF (AMP2.GT.ZERO) THEN
26063          ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26064          PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26065       ELSE
26066          ETARG = TINY10
26067          PTARG = TINY10
26068       ENDIF
26069 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26070       IF (IDP.EQ.7) THEN
26071          PGAMM(1) = ZERO
26072          PGAMM(2) = ZERO
26073          AMGAM  = AMP
26074          AMGAM2 = AMP2
26075          IF (ECM0.GT.ZERO) THEN
26076             S = ECM0**2
26077          ELSE
26078             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26079                S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26080             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26081                S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26082             ENDIF
26083          ENDIF
26084          PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26085      &                     +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26086          PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26087          IF (MODE.EQ.1) THEN
26088             PNUCL(1) = ZERO
26089             PNUCL(2) = ZERO
26090             PNUCL(3) = -PGAMM(3)
26091             PNUCL(4) = SQRT(S)-PGAMM(4)
26092          ENDIF
26093       ENDIF
26094       IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26095      &    (IDPR.EQ.10).OR.(IDPR.EQ.11))   THEN
26096          PLEPT0(1) = ZERO
26097          PLEPT0(2) = ZERO
26098 * neglect lepton masses
26099 C        AMLPT2   = AAM(IDPR)**2
26100          AMLPT2   = ZERO
26101 *
26102          IF (ECM0.GT.ZERO) THEN
26103             S = ECM0**2
26104          ELSE
26105             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26106                S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26107             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26108                S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26109             ENDIF
26110          ENDIF
26111          PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26112      &                     +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26113          PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26114          PNUCL(1) = ZERO
26115          PNUCL(2) = ZERO
26116          PNUCL(3) = -PLEPT0(3)
26117          PNUCL(4) = SQRT(S)-PLEPT0(4)
26118       ENDIF
26119 * Lorentz-parameter for transformation Lab. - projectile rest system
26120       IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26121          GALAB = TINY10
26122          BGLAB = TINY10
26123          BLAB  = TINY10
26124       ELSE
26125          GALAB = EPROJ/AMP
26126          BGLAB = PPROJ/AMP
26127          BLAB  = BGLAB/GALAB
26128       ENDIF
26129 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26130       IF (IDP.EQ.7) THEN
26131          GACMS(1) = TINY10
26132          BGCMS(1) = TINY10
26133       ELSE
26134          GACMS(1) = (ETARG+AMP)/UMO
26135          BGCMS(1) = PTARG/UMO
26136       ENDIF
26137 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26138       GACMS(2) = (EPROJ+AMT)/UMO
26139       BGCMS(2) = PPROJ/UMO
26140       PPCM     = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26141
26142       EPN0 = EPN
26143       PPN0 = PPN
26144       ECM0 = ECM
26145
26146       RETURN
26147       END
26148
26149 *$ CREATE DT_LTRANS.FOR
26150 *COPY DT_LTRANS
26151 *
26152 *===ltrans=============================================================*
26153 *
26154       SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26155
26156 ************************************************************************
26157 * Lorentz-transformations.                                             *
26158 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26159 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26160 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26161 * This version dated 01.11.95 is written by  S. Roesler.               *
26162 ************************************************************************
26163
26164       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26165       SAVE
26166
26167       PARAMETER ( LINP = 10 ,
26168      &            LOUT = 6 ,
26169      &            LDAT = 9 )
26170
26171       PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26172
26173       PARAMETER (SQTINF=1.0D+15)
26174
26175 * particle properties (BAMJET index convention)
26176       CHARACTER*8  ANAME
26177       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26178      &                IICH(210),IIBAR(210),K1(210),K2(210)
26179
26180       PXO = PXI
26181       PYO = PYI
26182       CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26183
26184 * check particle mass for consistency (numerical rounding errors)
26185       PO     = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26186       AMO2   = (PEO-PO)*(PEO+PO)
26187       AMORQ2 = AAM(ID)**2
26188       AMDIF2 = ABS(AMO2-AMORQ2)
26189       IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26190          DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26191          PEO   = PEO+DELTA
26192          PO1   = PO -DELTA
26193          PXO   = PXO*PO1/PO
26194          PYO   = PYO*PO1/PO
26195          PZO   = PZO*PO1/PO
26196 C        WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26197       ENDIF
26198
26199       RETURN
26200       END
26201
26202 *$ CREATE DT_LTNUC.FOR
26203 *COPY DT_LTNUC
26204 *
26205 *===ltnuc==============================================================*
26206 *
26207       SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26208
26209 ************************************************************************
26210 * Lorentz-transformations.                                             *
26211 *   PIN        longitudnal momentum       (input)                      *
26212 *   EIN        energy                     (input)                      *
26213 *   POUT       transformed long. momentum (output)                     *
26214 *   EOUT       transformed energy         (output)                     *
26215 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26216 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26217 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26218 * This version dated 01.11.95 is written by  S. Roesler.               *
26219 ************************************************************************
26220
26221       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26222       SAVE
26223
26224       PARAMETER ( LINP = 10 ,
26225      &            LOUT = 6 ,
26226      &            LDAT = 9 )
26227
26228       PARAMETER (ZERO=0.0D0)
26229
26230 * Lorentz-parameters of the current interaction
26231       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26232      &                UMO,PPCM,EPROJ,PPROJ
26233
26234       BDUM1 = ZERO
26235       BDUM2 = ZERO
26236       PDUM1 = ZERO
26237       PDUM2 = ZERO
26238       IF (ABS(MODE).EQ.1) THEN
26239          BG = -SIGN(BGLAB,DBLE(MODE))
26240          CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26241      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26242       ELSEIF (ABS(MODE).EQ.2) THEN
26243          BG = SIGN(BGCMS(1),DBLE(MODE))
26244          CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26245      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26246       ELSEIF (ABS(MODE).EQ.3) THEN
26247          BG = -SIGN(BGCMS(2),DBLE(MODE))
26248          CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26249      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26250       ELSE
26251          WRITE(LOUT,1000) MODE
26252  1000    FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26253          EOUT = EIN
26254          POUT = PIN
26255       ENDIF
26256
26257       RETURN
26258       END
26259
26260 *$ CREATE DT_DALTRA.FOR
26261 *COPY DT_DALTRA
26262 *
26263 *===daltra=============================================================*
26264 *
26265       SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26266
26267 ************************************************************************
26268 * Arbitrary Lorentz-transformation.                                    *
26269 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
26270 ************************************************************************
26271
26272       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26273       SAVE
26274       PARAMETER (ONE=1.0D0)
26275
26276       EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26277       PE = EP/(GA+ONE)+EC
26278       PX = PCX+BGX*PE
26279       PY = PCY+BGY*PE
26280       PZ = PCZ+BGZ*PE
26281       P  = SQRT(PX*PX+PY*PY+PZ*PZ)
26282       E  = GA*EC+EP
26283
26284       RETURN
26285       END
26286
26287 *$ CREATE DT_DTRAFO.FOR
26288 *COPY DT_DTRAFO
26289 *
26290 *====dtrafo============================================================*
26291 *
26292       SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26293      &                                    PL,CXL,CYL,CZL,EL)
26294
26295 C     LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26296
26297       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26298       SAVE
26299
26300       IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26301       SID  = SQRT(1.D0-COD*COD)
26302       PLX  = P*SID*COF
26303       PLY  = P*SID*SIF
26304       PCMZ = P*COD
26305       PLZ  = GAM*PCMZ+BGAM*ECM
26306       PL   = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26307       EL   = GAM*ECM+BGAM*PCMZ
26308 C     ROTATION INTO THE ORIGINAL DIRECTION
26309       COZ  = PLZ/PL
26310       SIZ  = SQRT(1.D0-COZ**2)
26311       CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26312
26313       RETURN
26314       END
26315
26316 *$ CREATE DT_STTRAN.FOR
26317 *COPY DT_STTRAN
26318 *
26319 *====sttran============================================================*
26320 *
26321       SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26322
26323       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26324       SAVE
26325       DATA ANGLSQ/1.D-30/
26326 ************************************************************************
26327 *     VERSION BY                     J. RANFT                          *
26328 *                                    LEIPZIG                           *
26329 *                                                                      *
26330 *     THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES      *
26331 *                                                                      *
26332 *     INPUT VARIABLES:                                                 *
26333 *        XO,YO,ZO = ORIGINAL DIRECTION COSINES                         *
26334 *        CDE,SDE  = COSINE AND SINE OF THE POLAR (THETA)               *
26335 *                   ANGLE OF "SCATTERING"                              *
26336 *        SDE      = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING"    *
26337 *        SFE,CFE  = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE       *
26338 *                   OF "SCATTERING"                                    *
26339 *                                                                      *
26340 *     OUTPUT VARIABLES:                                                *
26341 *        X,Y,Z     = NEW DIRECTION COSINES                             *
26342 *                                                                      *
26343 *     ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 )                  *
26344 ************************************************************************
26345 *
26346 *
26347 *  Changed by A. Ferrari
26348 *
26349 *     IF (ABS(XO)-0.0001D0) 1,1,2
26350 *   1 IF (ABS(YO)-0.0001D0) 3,3,2
26351 *   3 CONTINUE
26352       A = XO**2 + YO**2
26353       IF ( A .LT. ANGLSQ ) THEN
26354          X=SDE*CFE
26355          Y=SDE*SFE
26356          Z=CDE*ZO
26357       ELSE
26358          XI=SDE*CFE
26359          YI=SDE*SFE
26360          ZI=CDE
26361          A=SQRT(A)
26362          X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26363          Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26364          Z=A*YI+ZO*ZI
26365       ENDIF
26366
26367       RETURN
26368       END
26369
26370 *$ CREATE DT_MYTRAN.FOR
26371 *COPY DT_MYTRAN
26372 *
26373 *===mytran=============================================================*
26374 *
26375       SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26376
26377 ************************************************************************
26378 * This subroutine rotates the coordinate frame                         *
26379 *    a) theta  around y                                                *
26380 *    b) phi    around z      if IMODE = 1                              *
26381 *                                                                      *
26382 *     x'          cos(ph) -sin(ph) 0      cos(th)  0  sin(th)   x      *
26383 *     y' = A B =  sin(ph) cos(ph)  0  .   0        1        0   y      *
26384 *     z'          0       0        1     -sin(th)  0  cos(th)   z      *
26385 *                                                                      *
26386 * and vice versa if IMODE = 0.                                         *
26387 * This version dated 5.4.94 is based on the original version DTRAN     *
26388 * by J. Ranft and is written by S. Roesler.                            *
26389 ************************************************************************
26390
26391       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26392       SAVE
26393
26394       PARAMETER ( LINP = 10 ,
26395      &            LOUT = 6 ,
26396      &            LDAT = 9 )
26397
26398       IF (IMODE.EQ.1) THEN
26399          X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26400          Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26401          Z=-SDE    *XO       +CDE    *ZO
26402       ELSE
26403          X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26404          Y= -SFE*XO+CFE*YO
26405          Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26406       ENDIF
26407       RETURN
26408       END
26409
26410 *$ CREATE DT_LT2LAO.FOR
26411 *COPY DT_LT2LAO
26412 *
26413 *===lt2lab=============================================================*
26414 *
26415       SUBROUTINE DT_LT2LAO
26416
26417 ************************************************************************
26418 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26419 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26420 * and transforms them back to the lab.                                 *
26421 * This version dated 16.11.95 is written by S. Roesler                 *
26422 ************************************************************************
26423
26424       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26425       SAVE
26426
26427       PARAMETER ( LINP = 10 ,
26428      &            LOUT = 6 ,
26429      &            LDAT = 9 )
26430
26431 * event history
26432
26433       PARAMETER (NMXHKK=200000)
26434
26435       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26436      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26437      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26438
26439 * extended event history
26440       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26441      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26442      &                IHIST(2,NMXHKK)
26443
26444       NEND      = NHKK
26445       NPOINT(5) = NHKK+1
26446       IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26447       DO 1 I=NPOINT(4),NEND
26448 C     DO 1 I=1,NEND
26449          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26450      &                                (ISTHKK(I).EQ.1001)) THEN
26451             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26452             NOB = NOBAM(I)
26453             CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26454      &                            PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26455             IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26456                ISTHKK(I) = 3*ISTHKK(I)
26457                NOBAM(NHKK)  = NOB
26458             ELSE
26459                IF (ISTHKK(I).EQ.-1) NOBAM(NHKK)  = NOB
26460                ISTHKK(I) = SIGN(3,ISTHKK(I))
26461             ENDIF
26462             JDAHKK(1,I) = NHKK
26463          ENDIF
26464     1 CONTINUE
26465
26466       RETURN
26467       END
26468
26469 *$ CREATE DT_LT2LAB.FOR
26470 *COPY DT_LT2LAB
26471 *
26472 *===lt2lab=============================================================*
26473 *
26474       SUBROUTINE DT_LT2LAB
26475
26476 ************************************************************************
26477 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26478 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26479 * and transforms them to the lab.                                      *
26480 * This version dated 07.01.96 is written by S. Roesler                 *
26481 ************************************************************************
26482
26483       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26484       SAVE
26485
26486       PARAMETER ( LINP = 10 ,
26487      &            LOUT = 6 ,
26488      &            LDAT = 9 )
26489
26490 * event history
26491
26492       PARAMETER (NMXHKK=200000)
26493
26494       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26495      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26496      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26497
26498 * extended event history
26499       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26500      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26501      &                IHIST(2,NMXHKK)
26502
26503       IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26504       DO 1 I=NPOINT(4),NHKK
26505          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26506      &                                (ISTHKK(I).EQ.1001)) THEN
26507             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26508             PHKK(3,I) = PZ
26509             PHKK(4,I) = PE
26510          ENDIF
26511     1 CONTINUE
26512
26513       RETURN
26514       END
26515
26516 ************************************************************************
26517 *                                                                      *
26518 *                 5) Sampling from distributions                       *
26519 *                                                                      *
26520 ************************************************************************
26521 *$ CREATE IDT_NPOISS.FOR
26522 *COPY IDT_NPOISS
26523 *
26524 *===npoiss=============================================================*
26525 *
26526       INTEGER FUNCTION IDT_NPOISS(AVN)
26527
26528 ************************************************************************
26529 * Sample according to Poisson distribution with Poisson parameter AVN. *
26530 * The original version written by J. Ranft.                            *
26531 * This version dated 11.1.95 is written by S. Roesler.                 *
26532 ************************************************************************
26533
26534       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26535       SAVE
26536
26537       PARAMETER ( LINP = 10 ,
26538      &            LOUT = 6 ,
26539      &            LDAT = 9 )
26540
26541       EXPAVN = EXP(-AVN)
26542       K = 1
26543       A = 1.0D0
26544
26545    10 CONTINUE
26546       A = DT_RNDM(A)*A
26547       IF (A.GE.EXPAVN) THEN
26548          K = K+1
26549          GOTO 10
26550       ENDIF
26551       IDT_NPOISS = K-1
26552
26553       RETURN
26554       END
26555
26556 *$ CREATE DT_SAMPXB.FOR
26557 *COPY DT_SAMPXB
26558 *
26559 *===sampxb=============================================================*
26560 *
26561       DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26562
26563 ************************************************************************
26564 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2.             *
26565 * Processed by S. Roesler, 6.5.95                                      *
26566 ************************************************************************
26567
26568       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26569       SAVE
26570       PARAMETER (TWO=2.0D0)
26571
26572       A1 = LOG(X1+SQRT(X1**2+B**2))
26573       A2 = LOG(X2+SQRT(X2**2+B**2))
26574       AN = A2-A1
26575       A  = AN*DT_RNDM(A1)+A1
26576       BB = EXP(A)
26577       DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26578
26579       RETURN
26580       END
26581
26582 *$ CREATE DT_SAMPEX.FOR
26583 *COPY DT_SAMPEX
26584 *
26585 *===sampex=============================================================*
26586 *
26587       DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26588
26589 ************************************************************************
26590 * Sampling from f(x)=1./x between x1 and x2.                           *
26591 * Processed by S. Roesler, 6.5.95                                      *
26592 ************************************************************************
26593
26594       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26595       SAVE
26596       PARAMETER (ONE=1.0D0)
26597
26598       R   = DT_RNDM(X1)
26599       AL1 = LOG(X1)
26600       AL2 = LOG(X2)
26601       DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26602
26603       RETURN
26604       END
26605
26606 *$ CREATE DT_SAMSQX.FOR
26607 *COPY DT_SAMSQX
26608 *
26609 *===samsqx=============================================================*
26610 *
26611       DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26612
26613 ************************************************************************
26614 * Sampling from f(x)=1./x^0.5 between x1 and x2.                       *
26615 * Processed by S. Roesler, 6.5.95                                      *
26616 ************************************************************************
26617
26618       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26619       SAVE
26620       PARAMETER (ONE=1.0D0)
26621
26622       R = DT_RNDM(X1)
26623       DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26624
26625       RETURN
26626       END
26627
26628 *$ CREATE DT_SAMPLW.FOR
26629 *COPY DT_SAMPLW
26630 *
26631 *===samplw=============================================================*
26632 *
26633       DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26634
26635 ************************************************************************
26636 * Sampling from f(x)=1/x^b between x_min and x_max.                    *
26637 * S. Roesler, 18.4.98                                                  *
26638 ************************************************************************
26639
26640       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26641       SAVE
26642       PARAMETER (ONE=1.0D0)
26643
26644       R = DT_RNDM(B)
26645       IF (B.EQ.ONE) THEN
26646          DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26647       ELSE
26648          ONEMB  = ONE-B
26649          DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26650       ENDIF
26651
26652       RETURN
26653       END
26654
26655 *$ CREATE DT_BETREJ.FOR
26656 *COPY DT_BETREJ
26657 *
26658 *===betrej=============================================================*
26659 *
26660       DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26661
26662       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26663       SAVE
26664
26665       PARAMETER ( LINP = 10 ,
26666      &            LOUT = 6 ,
26667      &            LDAT = 9 )
26668
26669       PARAMETER (ONE=1.0D0)
26670
26671       IF (XMIN.GE.XMAX)THEN
26672          WRITE (LOUT,500) XMIN,XMAX
26673   500    FORMAT(1X,'DT_BETREJ:  XMIN<XMAX execution stopped ',2F10.5)
26674          STOP
26675       ENDIF
26676
26677    10 CONTINUE
26678       XX     = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26679       BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26680       YY     = BETMAX*DT_RNDM(XX)
26681       BETXX  = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26682       IF (YY.GT.BETXX) GOTO 10
26683       DT_BETREJ = XX
26684
26685       RETURN
26686       END
26687
26688 *$ CREATE DT_DGAMRN.FOR
26689 *COPY DT_DGAMRN
26690 *
26691 *===dgamrn=============================================================*
26692 *
26693       DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26694
26695 ************************************************************************
26696 * Sampling from Gamma-distribution.                                    *
26697 *       F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)            *
26698 * Processed by S. Roesler, 6.5.95                                      *
26699 ************************************************************************
26700
26701       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26702       SAVE
26703       PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26704
26705       NCOU = 0
26706       N    = INT(ETA)
26707       F    = ETA-DBLE(N)
26708       IF (F.EQ.ZERO) GOTO 20
26709    10 R = DT_RNDM(F)
26710       NCOU = NCOU+1
26711       IF (NCOU.GE.11) GOTO 20
26712       IF (R.LT.F/(F+2.71828D0)) GOTO 30
26713       YYY = LOG(DT_RNDM(R)+TINY9)/F
26714       IF (ABS(YYY).GT.50.0D0) GOTO 20
26715       Y = EXP(YYY)
26716       IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26717       GOTO 40
26718    20 Y = 0.0D0
26719       GOTO 50
26720    30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26721       IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
26722    40 IF (N.EQ.0) GOTO 70
26723    50 Z = 1.0D0
26724       DO 60 I = 1,N
26725    60 Z = Z*DT_RNDM(Z)
26726       Y = Y-LOG(Z+TINY9)
26727    70 DT_DGAMRN = Y/ALAM
26728
26729       RETURN
26730       END
26731
26732 *$ CREATE DT_DBETAR.FOR
26733 *COPY DT_DBETAR
26734 *
26735 *===dbetar=============================================================*
26736 *
26737       DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
26738
26739 ************************************************************************
26740 * Sampling from Beta -distribution between 0.0 and 1.0                 *
26741 *  F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
26742 * Processed by S. Roesler, 6.5.95                                      *
26743 ************************************************************************
26744
26745       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26746       SAVE
26747
26748       Y = DT_DGAMRN(1.0D0,GAM)
26749       Z = DT_DGAMRN(1.0D0,ETA)
26750       DT_DBETAR = Y/(Y+Z)
26751
26752       RETURN
26753       END
26754
26755 *$ CREATE DT_RANNOR.FOR
26756 *COPY DT_RANNOR
26757 *
26758 *===rannor=============================================================*
26759 *
26760       SUBROUTINE DT_RANNOR(X,Y)
26761
26762 ************************************************************************
26763 * Sampling from Gaussian distribution.                                 *
26764 * Processed by S. Roesler, 6.5.95                                      *
26765 ************************************************************************
26766
26767       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26768       SAVE
26769       PARAMETER (TINY10=1.0D-10)
26770
26771       CALL DT_DSFECF(SFE,CFE)
26772       V = MAX(TINY10,DT_RNDM(X))
26773       A = SQRT(-2.D0*LOG(V))
26774       X = A*SFE
26775       Y = A*CFE
26776
26777       RETURN
26778       END
26779
26780 *$ CREATE DT_DPOLI.FOR
26781 *COPY DT_DPOLI
26782 *
26783 *===dpoli==============================================================*
26784 *
26785       SUBROUTINE DT_DPOLI(CS,SI)
26786
26787       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26788       SAVE
26789
26790       U  = DT_RNDM(CS)
26791       CS = DT_RNDM(U)
26792       IF (U.LT.0.5D0) CS=-CS
26793       SI = SQRT(1.0D0-CS*CS+1.0D-10)
26794
26795       RETURN
26796       END
26797
26798 *$ CREATE DT_DSFECF.FOR
26799 *COPY DT_DSFECF
26800 *
26801 *===dsfecf=============================================================*
26802 *
26803       SUBROUTINE DT_DSFECF(SFE,CFE)
26804
26805       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26806       SAVE
26807       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26808
26809     1 CONTINUE
26810       X  = DT_RNDM(SFE)
26811       Y  = DT_RNDM(X)
26812       XX = X*X
26813       YY = Y*Y
26814       XY = XX+YY
26815       IF (XY.GT.ONE) GOTO 1
26816       CFE = (XX-YY)/XY
26817       SFE = TWO*X*Y/XY
26818       IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
26819       RETURN
26820       END
26821
26822 *$ CREATE DT_RACO.FOR
26823 *COPY DT_RACO
26824 *
26825 *===raco===============================================================*
26826 *
26827       SUBROUTINE DT_RACO(WX,WY,WZ)
26828
26829 ************************************************************************
26830 * Direction cosines of random uniform (isotropic) direction in three   *
26831 * dimensional space                                                    *
26832 * Processed by S. Roesler, 20.11.95                                    *
26833 ************************************************************************
26834
26835       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26836       SAVE
26837       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26838
26839   10  CONTINUE
26840       X  = TWO*DT_RNDM(WX)-ONE
26841       Y  = DT_RNDM(X)
26842       X2 = X*X
26843       Y2 = Y*Y
26844       IF (X2+Y2.GT.ONE) GOTO 10
26845
26846       CFE = (X2-Y2)/(X2+Y2)
26847       SFE = TWO*X*Y/(X2+Y2)
26848 * z = 1/2 [ 1 + cos (theta) ]
26849       Z   = DT_RNDM(X)
26850 * 1/2 sin (theta)
26851       WZ = SQRT(Z*(ONE-Z))
26852       WX = TWO*WZ*CFE
26853       WY = TWO*WZ*SFE
26854       WZ = TWO*Z-ONE
26855
26856       RETURN
26857       END
26858
26859 ************************************************************************
26860 *                                                                      *
26861 *           6) Special functions, algorithms and service routines      *
26862 *                                                                      *
26863 ************************************************************************
26864 *$ CREATE DT_YLAMB.FOR
26865 *COPY DT_YLAMB
26866 *
26867 *===ylamb==============================================================*
26868 *
26869       DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
26870
26871 ************************************************************************
26872 *                                                                      *
26873 *     auxiliary function for three particle decay mode                 *
26874 *     (standard LAMBDA**(1/2) function)                                *
26875 *                                                                      *
26876 * Adopted from an original version written by R. Engel.                *
26877 * This version dated 12.12.94 is written by S. Roesler.                *
26878 ************************************************************************
26879
26880       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26881       SAVE
26882
26883       YZ   = Y-Z
26884       XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
26885       IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
26886       DT_YLAMB = SQRT(XLAM)
26887
26888       RETURN
26889       END
26890
26891 *$ CREATE DT_SORT.FOR
26892 *COPY DT_SORT
26893 *
26894 *===sort1==============================================================*
26895 *
26896       SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
26897
26898 ************************************************************************
26899 * This subroutine sorts entries in A in increasing/decreasing order    *
26900 * of A(3,i).                                                           *
26901 *              MODE  = 1     increasing in A(3,i=1..N)                 *
26902 *                    = 2     decreasing in A(3,i=1..N)                 *
26903 * This version dated 21.04.95 is revised by S. Roesler                 *
26904 ************************************************************************
26905
26906       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26907       SAVE
26908
26909       DIMENSION A(3,N)
26910
26911       M = I1
26912    10 CONTINUE
26913       M = I1-1
26914       IF (M.LE.0) RETURN
26915       L = 0
26916       DO 20 I=I0,M
26917          J = I+1
26918          IF (MODE.EQ.1) THEN
26919             IF (A(3,I).LE.A(3,J)) GOTO 20
26920          ELSE
26921             IF (A(3,I).GE.A(3,J)) GOTO 20
26922          ENDIF
26923          B = A(3,I)
26924          C = A(1,I)
26925          D = A(2,I)
26926          A(3,I) = A(3,J)
26927          A(2,I) = A(2,J)
26928          A(1,I) = A(1,J)
26929          A(3,J) = B
26930          A(1,J) = C
26931          A(2,J) = D
26932          L = 1
26933    20 CONTINUE
26934       IF (L.EQ.1) GOTO 10
26935
26936       RETURN
26937       END
26938
26939 *$ CREATE DT_SORT1.FOR
26940 *COPY DT_SORT1
26941 *
26942 *===sort1==============================================================*
26943 *
26944       SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
26945
26946 ************************************************************************
26947 * This subroutine sorts entries in A in increasing/decreasing order    *
26948 * of A(i).                                                             *
26949 *              MODE  = 1     increasing in A(i=1..N)                   *
26950 *                    = 2     decreasing in A(i=1..N)                   *
26951 * This version dated 21.04.95 is revised by S. Roesler                 *
26952 ************************************************************************
26953
26954       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26955       SAVE
26956
26957       DIMENSION A(N),IDX(N)
26958
26959       M = I1
26960    10 CONTINUE
26961       M = I1-1
26962       IF (M.LE.0) RETURN
26963       L = 0
26964       DO 20 I=I0,M
26965          J = I+1
26966          IF (MODE.EQ.1) THEN
26967             IF (A(I).LE.A(J)) GOTO 20
26968          ELSE
26969             IF (A(I).GE.A(J)) GOTO 20
26970          ENDIF
26971          B    = A(I)
26972          A(I) = A(J)
26973          A(J) = B
26974          IX     = IDX(I)
26975          IDX(I) = IDX(J)
26976          IDX(J) = IX
26977          L = 1
26978    20 CONTINUE
26979       IF (L.EQ.1) GOTO 10
26980
26981       RETURN
26982       END
26983
26984 *$ CREATE DT_XTIME.FOR
26985 *COPY DT_XTIME
26986 *
26987 *===xtime==============================================================*
26988 *
26989       SUBROUTINE DT_XTIME
26990
26991       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26992       SAVE
26993
26994       PARAMETER ( LINP = 10 ,
26995      &            LOUT = 6 ,
26996      &            LDAT = 9 )
26997
26998       CHARACTER DAT*9,TIM*11
26999
27000       DAT = '         '
27001       TIM = '           '
27002 C     CALL GETDAT(IYEAR,IMONTH,IDAY)
27003 C     CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
27004
27005 C     CALL DATE(DAT)
27006 C     CALL TIME(TIM)
27007 C     WRITE(LOUT,1000) DAT,TIM
27008  1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27009
27010       RETURN
27011       END
27012
27013 ************************************************************************
27014 *                                                                      *
27015 *                 7) Random number generator package                   *
27016 *                                                                      *
27017 *    THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND        *
27018 *    SERVICE ROUTINES.                                                 *
27019 *    THE ALGORITHM IS FROM                                             *
27020 *      'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR'                     *
27021 *      G.MARSAGLIA, A.ZAMAN ;  FSU-SCRI-87-50                          *
27022 *    IMPLEMENTATION BY K. HAHN  DEC. 88,                               *
27023 *    THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27024 *    AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ),        *
27025 *    THE PERIOD IS ABOUT 2**144,                                       *
27026 *    TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS,            *
27027 *    THE PACKAGE CONTAINS                                              *
27028 *      FUNCTION DT_RNDM(I)                  : GENERATOR                *
27029 *      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION           *
27030 *      SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)  : PUT SEED TO GENERATOR    *
27031 *      SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)  : TAKE SEED FROM GENERATOR *
27032 *      SUBROUTINE DT_RNDMTE(IO)             : TEST OF GENERATOR        *
27033 *---                                                                   *
27034 *    FUNCTION DT_RNDM(I)                                               *
27035 *       GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS  IN (0..1)          *
27036 *       I  - DUMMY VARIABLE, NOT USED                                  *
27037 *    SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)                             *
27038 *       INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27039 *       NA1,NA2,NA3,NB1  - VALUES FOR INITIALIZING THE GENERATOR       *
27040 *                          NA? MUST BE IN 1..178 AND NOT ALL 1         *
27041 *                          12,34,56  ARE THE STANDARD VALUES           *
27042 *                          NB1 MUST BE IN 1..168                       *
27043 *                          78  IS THE STANDARD VALUE                   *
27044 *    SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)                               *
27045 *       PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS   *
27046 *       AS AFTER THE LAST DT_RNDMOU CALL )                             *
27047 *       U(97),C,CD,CM,I,J  - SEED VALUES AS TAKEN FROM DT_RNDMOU       *
27048 *    SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)                               *
27049 *       TAKES SEED FROM GENERATOR                                      *
27050 *       U(97),C,CD,CM,I,J  - SEED VALUES                               *
27051 *    SUBROUTINE DT_RNDMTE(IO)                                          *
27052 *       TEST OF THE GENERATOR                                          *
27053 *       IO     - DEFINES OUTPUT                                        *
27054 *                  = 0  OUTPUT ONLY IF AN ERROR IS DETECTED            *
27055 *                  = 1  OUTPUT INDEPENDEND ON AN ERROR                 *
27056 *       DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO   *
27057 *       SAME STATUS                                                    *
27058 *       AS BEFORE CALL OF DT_RNDMTE                                    *
27059 ************************************************************************
27060 *$ CREATE DT_RNDM.FOR
27061 *COPY DT_RNDM
27062 *
27063 *===rndm===============================================================*
27064 *
27065 c$$$      DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27066 c$$$
27067 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27068 c$$$      SAVE
27069 c$$$
27070 c$$$* counter of calls to random number generator
27071 c$$$* uncomment if needed
27072 c$$$C     COMMON /DTRNCT/ IRNCT0,IRNCT1
27073 c$$$C     LOGICAL LFIRST
27074 c$$$C     DATA LFIRST /.TRUE./
27075 c$$$
27076 c$$$* counter of calls to random number generator
27077 c$$$* uncomment if needed
27078 c$$$C     IF (LFIRST) THEN
27079 c$$$C        IRNCT0 = 0
27080 c$$$C        IRNCT1 = 0
27081 c$$$C        LFIRST = .FALSE.
27082 c$$$C     ENDIF
27083 c$$$
27084 c$$$      DT_RNDM = FLRNDM(VDUMMY)
27085 c$$$* counter of calls to random number generator
27086 c$$$* uncomment if needed
27087 c$$$C     IRNCT1 = IRNCT1+1
27088 c$$$
27089 c$$$      RETURN
27090 c$$$      END
27091 c$$$
27092 c$$$*$ CREATE DT_RNDMST.FOR
27093 c$$$*COPY DT_RNDMST
27094 c$$$*
27095 c$$$*===rndmst=============================================================*
27096 c$$$*
27097 c$$$      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27098 c$$$
27099 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27100 c$$$      SAVE
27101 c$$$
27102 c$$$* random number generator
27103 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27104 c$$$
27105 c$$$      MA1 = NA1
27106 c$$$      MA2 = NA2
27107 c$$$      MA3 = NA3
27108 c$$$      MB1 = NB1
27109 c$$$      I   = 97
27110 c$$$      J   = 33
27111 c$$$      DO 20 II2 = 1,97
27112 c$$$        S = 0
27113 c$$$        T = 0.5D0
27114 c$$$        DO 10 II1 = 1,24
27115 c$$$          MAT  = MOD(MOD(MA1*MA2,179)*MA3,179)
27116 c$$$          MA1  = MA2
27117 c$$$          MA2  = MA3
27118 c$$$          MA3  = MAT
27119 c$$$          MB1  = MOD(53*MB1+1,169)
27120 c$$$          IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27121 c$$$   10   T = 0.5D0*T
27122 c$$$   20 U(II2) = S
27123 c$$$      C  =   362436.0D0/16777216.0D0
27124 c$$$      CD =  7654321.0D0/16777216.0D0
27125 c$$$      CM = 16777213.0D0/16777216.0D0
27126 c$$$      RETURN
27127 c$$$      END
27128 c$$$
27129 c$$$*$ CREATE DT_RNDMIN.FOR
27130 c$$$*COPY DT_RNDMIN
27131 c$$$*
27132 c$$$*===rndmin=============================================================*
27133 c$$$*
27134 c$$$      SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27135 c$$$
27136 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27137 c$$$      SAVE
27138 c$$$
27139 c$$$* random number generator
27140 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27141 c$$$
27142 c$$$      DIMENSION UIN(97)
27143 c$$$
27144 c$$$      DO 10 KKK = 1,97
27145 c$$$   10 U(KKK) = UIN(KKK)
27146 c$$$      C  = CIN
27147 c$$$      CD = CDIN
27148 c$$$      CM = CMIN
27149 c$$$      I  = IIN
27150 c$$$      J  = JIN
27151 c$$$
27152 c$$$      RETURN
27153 c$$$      END
27154 c$$$
27155 c$$$*$ CREATE DT_RNDMOU.FOR
27156 c$$$*COPY DT_RNDMOU
27157 c$$$*
27158 c$$$*===rndmou=============================================================*
27159 c$$$*
27160 c$$$      SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27161 c$$$
27162 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27163 c$$$      SAVE
27164 c$$$
27165 c$$$* random number generator
27166 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27167 c$$$
27168 c$$$      DIMENSION UOUT(97)
27169 c$$$
27170 c$$$      DO 10 KKK = 1,97
27171 c$$$   10 UOUT(KKK) = U(KKK)
27172 c$$$      COUT  = C
27173 c$$$      CDOUT = CD
27174 c$$$      CMOUT = CM
27175 c$$$      IOUT  = I
27176 c$$$      JOUT  = J
27177 c$$$
27178 c$$$      RETURN
27179 c$$$      END
27180 c$$$
27181 c$$$*$ CREATE DT_RNDMTE.FOR
27182 c$$$*COPY DT_RNDMTE
27183 c$$$*
27184 c$$$*===rndmte=============================================================*
27185 c$$$*
27186 c$$$      SUBROUTINE DT_RNDMTE(IO)
27187 c$$$
27188 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27189 c$$$      SAVE
27190 c$$$
27191 c$$$      DIMENSION UU(97),U(6),X(6),D(6)
27192 c$$$      DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27193 c$$$     +8354498.D0, 10633180.D0/
27194 c$$$
27195 c$$$      CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27196 c$$$      CALL DT_RNDMST(12,34,56,78)
27197 c$$$      DO 10 II1 = 1,20000
27198 c$$$   10 XX = DT_RNDM(XX)
27199 c$$$      SD        = 0.0D0
27200 c$$$      DO 20 II2 = 1,6
27201 c$$$        X(II2)  = 4096.D0*(4096.D0*DT_RNDM(SD))
27202 c$$$        D(II2)  = X(II2)-U(II2)
27203 c$$$   20 SD = SD+D(II2)
27204 c$$$      CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27205 c$$$**sr 24.01.95
27206 c$$$C     IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27207 c$$$      IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27208 c$$$C        WRITE(6,1000)
27209 c$$$ 1000    FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27210 c$$$     &          ' passed')
27211 c$$$      ENDIF
27212 c$$$**
27213 c$$$      RETURN
27214 c$$$  500 FORMAT('  === TEST OF THE RANDOM-GENERATOR ===',/,
27215 c$$$     &'    EXPECTED VALUE    CALCULATED VALUE     DIFFERENCE',/, 6(F17.
27216 c$$$     &1,F20.1,F15.3,/), '  === END OF TEST ;',
27217 c$$$     &'  GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27218 c$$$      END
27219 *
27220 *$ CREATE PHO_RNDM.FOR
27221 *COPY PHO_RNDM
27222 *
27223 *===pho_rndm===========================================================*
27224 *
27225       DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27226
27227       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27228       SAVE
27229
27230       PHO_RNDM = DT_RNDM(DUMMY)
27231
27232       RETURN
27233       END
27234
27235 *$ CREATE PYR.FOR
27236 *COPY PYR
27237 *
27238 *===pyr================================================================*
27239 *
27240       DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27241
27242       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27243       SAVE
27244
27245       DUMMY = DBLE(IDUMMY)
27246       PYR = DT_RNDM(DUMMY)
27247
27248       RETURN
27249       END
27250 *$ CREATE DT_TITLE.FOR
27251 *COPY DT_TITLE
27252 *
27253 *===title==============================================================*
27254 *
27255       SUBROUTINE DT_TITLE
27256
27257       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27258       SAVE
27259
27260       PARAMETER ( LINP = 10 ,
27261      &            LOUT = 6 ,
27262      &            LDAT = 9 )
27263
27264       CHARACTER*6 CVERSI
27265       CHARACTER*11 CCHANG
27266       DATA CVERSI,CCHANG /'3.0-5 ','31 Oct 2008'/
27267
27268       CALL DT_XTIME
27269       WRITE(LOUT,1000) CVERSI,CCHANG
27270  1000 FORMAT(1X,'+-------------------------------------------------',
27271      &                  '----------------------+',/,
27272      &     1X,'|',71X,'|',/,
27273      &     1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27274      &     1X,'|',71X,'|',/,
27275      &     1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27276      &     1X,'|',71X,'|',/,
27277      &     1X,'|',12X,'Authors: Stefan Roesler   (CERN)',27X,'|',/,
27278      &     1X,'|',21X,'Ralph Engel      (FZ Karlsruhe)',19X,'|',/,
27279      &     1X,'|',21X,'Johannes Ranft   (Siegen Univ.)',19X,'|',/,
27280 C    &     1X,'|',71X,'|',/,
27281 C    &     1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27282 C    &                                              17X,'|',/,
27283      &     1X,'|',71X,'|',/,
27284      &     1X,'+-------------------------------------------------',
27285      &                '----------------------+',/,
27286      &     1X,'| Please send suggestions, bug reports, etc. to: ',
27287      &                                  'Stefan.Roesler@cern.ch |',/,
27288      &     1X,'+-------------------------------------------------',
27289      &                '----------------------+',/)
27290
27291       RETURN
27292       END
27293
27294 *$ CREATE DT_EVTINI.FOR
27295 *COPY DT_EVTINI
27296 *
27297 *===evtini=============================================================*
27298 *
27299       SUBROUTINE DT_EVTINI
27300
27301 ************************************************************************
27302 * Initialization of DTEVT1.                                            *
27303 * This version dated 15.01.94 is written by S. Roesler                 *
27304 ************************************************************************
27305
27306       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27307       SAVE
27308
27309       PARAMETER ( LINP = 10 ,
27310      &            LOUT = 6 ,
27311      &            LDAT = 9 )
27312
27313 * event history
27314
27315       PARAMETER (NMXHKK=200000)
27316
27317       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27318      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27319      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27320
27321 * extended event history
27322       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27323      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27324      &                IHIST(2,NMXHKK)
27325
27326 * event flag
27327       COMMON /DTEVNO/ NEVENT,ICASCA
27328
27329       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27330
27331 * emulsion treatment
27332       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27333      &                NCOMPO,IEMUL
27334
27335 * initialization of DTEVT1/DTEVT2
27336       NEND = NHKK
27337       IF (NEVENT.EQ.1) NEND = NMXHKK
27338       NHKK   = 0
27339       NEVHKK = NEVENT
27340       DO 1 I=1,NEND
27341          ISTHKK(I)   = 0
27342          IDHKK(I)    = 0
27343          JMOHKK(1,I) = 0
27344          JMOHKK(2,I) = 0
27345          JDAHKK(1,I) = 0
27346          JDAHKK(2,I) = 0
27347          IDRES(I)    = 0
27348          IDXRES(I)   = 0
27349          NOBAM(I)    = 0
27350          IDCH(I)     = 0
27351          IHIST(1,I)  = 0
27352          IHIST(2,I)  = 0
27353          DO 2 J=1,4
27354             PHKK(J,I) = 0.0D0
27355             VHKK(J,I) = 0.0D0
27356             WHKK(J,I) = 0.0D0
27357     2    CONTINUE
27358          PHKK(5,I) = 0.0D0
27359     1 CONTINUE
27360       DO 3 I=1,10
27361          NPOINT(I) = 0
27362     3 CONTINUE
27363       CALL DT_CHASTA(-1)
27364
27365 C* initialization of DTLTRA
27366 C      IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27367
27368       RETURN
27369       END
27370
27371 *$ CREATE DT_STATIS.FOR
27372 *COPY DT_STATIS
27373 *
27374 *===statis=============================================================*
27375 *
27376       SUBROUTINE DT_STATIS(MODE)
27377
27378 ************************************************************************
27379 * Initialization and output of run-statistics.                         *
27380 *              MODE  = 1     initialization                            *
27381 *                    = 2     output                                    *
27382 * This version dated 23.01.94 is written by S. Roesler                 *
27383 ************************************************************************
27384
27385       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27386       SAVE
27387
27388       PARAMETER ( LINP = 10 ,
27389      &            LOUT = 6 ,
27390      &            LDAT = 9 )
27391
27392       PARAMETER (TINY3=1.0D-3)
27393
27394 * statistics
27395       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27396      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27397      &                ICEVTG(8,0:30)
27398
27399 * rejection counter
27400       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27401      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27402      &                IREXCI(3),IRDIFF(2),IRINC
27403
27404 * central particle production, impact parameter biasing
27405       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27406
27407 * various options for treatment of partons (DTUNUC 1.x)
27408 * (chain recombination, Cronin,..)
27409       LOGICAL LCO2CR,LINTPT
27410       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27411      &                LCO2CR,LINTPT
27412
27413 * nucleon-nucleon event-generator
27414       CHARACTER*8 CMODEL
27415       LOGICAL LPHOIN
27416       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27417
27418 * flags for particle decays
27419       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27420      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27421      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27422
27423 * diquark-breaking mechanism
27424       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27425
27426       DIMENSION PP(4),PT(4)
27427
27428       GOTO (1,2) MODE
27429
27430 * initialization
27431     1 CONTINUE
27432
27433 *   initialize statistics counter
27434       ICREQU = 0
27435       ICSAMP = 0
27436       ICCPRO = 0
27437       ICDPR  = 0
27438       ICDTA  = 0
27439       ICRJSS = 0
27440       ICVV2S = 0
27441       DO 10 I=1,9
27442          ICRES(I)    = 0
27443          ICCHAI(1,I) = 0
27444          ICCHAI(2,I) = 0
27445    10 CONTINUE
27446 *   initialize rejection counter
27447       IRPT      = 0
27448       IRHHA     = 0
27449       LOMRES    = 0
27450       LOBRES    = 0
27451       IRFRAG    = 0
27452       IREVT     = 0
27453       IRRES(1)  = 0
27454       IRRES(2)  = 0
27455       IRCHKI(1) = 0
27456       IRCHKI(2) = 0
27457       IRCRON(1) = 0
27458       IRCRON(2) = 0
27459       IRCRON(3) = 0
27460       IRDIFF(1) = 0
27461       IRDIFF(2) = 0
27462       IRINC     = 0
27463       DO 11 I=1,5
27464          ICDIFF(I) = 0
27465    11 CONTINUE
27466       DO 12 I=1,8
27467          DO 13 J=0,30
27468             ICEVTG(I,J) = 0
27469    13    CONTINUE
27470    12 CONTINUE
27471
27472       RETURN
27473
27474 * output
27475     2 CONTINUE
27476
27477 *   statistics counter
27478       WRITE(LOUT,1000)
27479  1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27480      &       28X,'---------------------')
27481       IF (ICREQU.GT.0) THEN
27482       WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27483  1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27484      &       I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27485      &       'event',11X,F9.1)
27486       ENDIF
27487       IF (ICDIFF(1).NE.0) THEN
27488          WRITE(LOUT,1009) ICDIFF
27489  1009    FORMAT(/,1X,'diffractive events:    total   ',I8,/,49X,
27490      &          'low mass   high mass',/,24X,'single diffraction',
27491      &          7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27492       ENDIF
27493       IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
27494          WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27495      &                    DBLE(ICSAMP)/DBLE(ICCPRO)
27496  1002    FORMAT(/,1X,'central production:',/,2X,'mean number',
27497      &          ' of sampled Glauber-events per event',9X,F9.1,/,
27498      &          2X,'fraction of production cross section',21X,F10.6)
27499       ENDIF
27500       IF (ICSAMP.GT.0) THEN
27501       WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27502      &                 DBLE(ICDTA)/DBLE(ICSAMP)
27503  1003 FORMAT(/,54X,'proj.    targ.',/,1X,'average number of wounded',
27504      &       ' nucleons after x-sampling',2(4X,F6.2))
27505       ENDIF
27506
27507       IF (MCGENE.EQ.1) THEN
27508          IF (ICSAMP.GT.0) THEN
27509          WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27510  1004    FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27511      &          ' event',3X,F9.1)
27512          IF (ISICHA.EQ.1) THEN
27513             WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27514  1005       FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27515      &             'of single chains  per event',13X,F9.1)
27516          ENDIF
27517          ENDIF
27518          IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
27519          WRITE(LOUT,1006)
27520  1006    FORMAT(/,1X,'chain system statistics:  (per event)',/,
27521      &       23X,'mean number of chains      mean number of chains',/,
27522      &       23X,'sampled    hadronized      having mass of a reso.')
27523          WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27524      &                     DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27525      &                     DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27526      &                  DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27527  1007    FORMAT(1X,'sea     - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27528      &          1X,'disea   - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27529      &          1X,'sea     - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27530      &          1X,'sea     - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27531      &          1X,'disea   - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27532      &          1X,'valence - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27533      &          1X,'valence - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27534      &          1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27535      &          1X,'fused chains      ',18X,F4.1,17X,F4.1,/)
27536          WRITE(LOUT,1008)
27537      &     (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27538      &     DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27539      &     DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27540      &     (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27541      &     (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27542      &     DBLE(IRHHA)/DBLE(ICREQU),
27543      &     DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27544      &     (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27545  1008    FORMAT(/,1X,'Rejection counter:  (NEVT = no. of events)',/,/,
27546      &       1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27547      &       F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27548      &       'Intrins. p_t (GETSPT)',21X,'IRPT     /NEVT = ',F7.2,/,
27549      &       1X,'Chain mass corr. for resonances (EVTRES)',2X,
27550      &       'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES)  IRRES(2) /',
27551      &       'NEVT = ',F7.2,/,43X,'LOMRES   /NEVT = ',F7.2,/,
27552      &       43X,'LOBRES   /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27553      &       ' 2-chain systems (CHKINE)  IRCHKI(1)/NEVT = ',F7.2,/,
27554      &       43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27555      &       'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27556      &       F7.2,/,1X,'Total no. of rej.',
27557      &       ' in chain-systems treatment (GETCSY)',/,43X,
27558      &       'IRHHA    /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27559      &       ' (not yet used!)',4X,'IRFRAG   /NEVT = ',F7.2,/,
27560      &       1X,'Total no. of rej. in DPM-treatment of one event',
27561      &       ' (EVENTA)',/,43X,'IREVT    /NEVT = ',F7.2,/,1X,
27562      &       'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27563      &       ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27564      &       'IREXCI(3) = ',I5,/)
27565          ENDIF
27566       ELSEIF (MCGENE.EQ.2) THEN
27567          WRITE(LOUT,1010) ELOJET
27568  1010    FORMAT(/,/,1X,'PHOJET-treatment of chain systems above  ',
27569      &          F4.1,' GeV')
27570          WRITE(LOUT,1011)
27571  1011    FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27572      &          30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27573      &          5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27574          WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27575      &                    (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27576      &                    (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27577      &                    ((ICEVTG(I,J),I=1,8),J=3,7),
27578      &                    ((ICEVTG(I,J),I=1,8),J=19,21),
27579      &                    (ICEVTG(I,8),I=1,8),
27580      &                    ((ICEVTG(I,J),I=1,8),J=22,24),
27581      &                    (ICEVTG(I,9),I=1,8),
27582      &                    ((ICEVTG(I,J),I=1,8),J=25,28),
27583      &                    ((ICEVTG(I,J),I=1,8),J=10,18)
27584  1012    FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27585      &          8I8,/,/,1X,'PHOJET ',8I8,/,'   sngl ',8I8,/,/,
27586      &          ' no-dif.',8I8,/,
27587      &          ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27588      &          ' diff-1 ',8I8,/,'  low   ',8I8,/,'  high  ',8I8,/,
27589      &          '  h-diff',8I8,/,' diff-2 ',8I8,/,'  low   ',8I8,/,
27590      &          '  high  ',8I8,/,'  h-diff',8I8,/,' dbl-di.',8I8,/,
27591      &          '  lo-lo ',8I8,/,'  hi-hi ',8I8,/,'  lo-hi ',8I8,/,
27592      &          '  hi-lo ',8I8,/,
27593      &          ' dir-ga.',8I8,/,/,' dir-1  ',8I8,/,' dir-2  ',8I8,/,
27594      &          ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27595      &          ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27596          WRITE(LOUT,1013)
27597  1013    FORMAT(/,1X,'2. chain system statistics -',
27598      &          ' mean numbers per evt:',/,30X,'---------------------',
27599      &          /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27600          IF (ICSAMP.GT.0) THEN
27601          WRITE(LOUT,1014)
27602      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27603      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27604      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27605  1014    FORMAT(/,1X,'req.to.    ',3E10.2,/,/,1X,'low rq.    ',3E10.2,/,
27606      &          1X,'low ac.    ',3E10.2,/,/,1X,'PHOJET     ',3E10.2,/,/,
27607      &          ' no-dif.    ',3E10.2,/,' el-sca.    ',3E10.2,/,
27608      &          ' qel-sc.    ',3E10.2,/,' dbl-Po.    ',3E10.2,/,
27609      &          ' diff-1     ',3E10.2,/,' diff-2     ',3E10.2,/,
27610      &          ' dbl-di.    ',3E10.2,/,' dir-ga.    ',3E10.2,/,/,
27611      &          ' dir-1      ',3E10.2,/,' dir-2      ',3E10.2,/,
27612      &          ' dbl-dir    ',3E10.2,/,' s-Pom.     ',3E10.2,/,
27613      &          ' h-Pom.     ',3E10.2,/,' s-Reg.     ',3E10.2,/,
27614      &          ' enh-trg    ',3E10.2,/,' enh-log    ',3E10.2)
27615          ENDIF
27616          WRITE(LOUT,1015)
27617  1015    FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27618          IF (ICSAMP.GT.0) THEN
27619          WRITE(LOUT,1016)
27620      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27621      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27622      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27623  1016    FORMAT(/,1X,'req.to.    ',5E10.2,/,/,1X,'low rq.    ',5E10.2,/,
27624      &          1X,'low ac.    ',5E10.2,/,/,1X,'PHOJET     ',5E10.2,/,/,
27625      &          ' no-dif.    ',5E10.2,/,' el-sca.    ',5E10.2,/,
27626      &          ' qel-sc.    ',5E10.2,/,' dbl-Po.    ',5E10.2,/,
27627      &          ' diff-1     ',5E10.2,/,' diff-2     ',5E10.2,/,
27628      &          ' dbl-di.    ',5E10.2,/,' dir-ga.    ',5E10.2,/,/,
27629      &          ' dir-1      ',5E10.2,/,' dir-2      ',5E10.2,/,
27630      &          ' dbl-dir    ',5E10.2,/,' s-Pom.     ',5E10.2,/,
27631      &          ' h-Pom.     ',5E10.2,/,' s-Reg.     ',5E10.2,/,
27632      &          ' enh-trg    ',5E10.2,/,' enh-log    ',5E10.2)
27633          ENDIF
27634
27635       ENDIF
27636       CALL DT_CHASTA(1)
27637
27638       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27639      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
27640          WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27641      &    DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27642      &    DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27643          WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27644      &    DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27645      &    DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27646          WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27647      &    DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27648      &    DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27649          WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27650      &    DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27651      &    DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27652          WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27653      &    DBRKA(3,1),DBRKA(3,2),
27654      &    DBRKA(3,3),DBRKA(3,4)
27655          WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27656      &    DBRKR(3,1),DBRKR(3,2),
27657      &    DBRKR(3,3),DBRKR(3,4)
27658          WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27659      &    DBRKA(3,5),DBRKA(3,6),
27660      &    DBRKA(3,7),DBRKA(3,8)
27661          WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27662      &    DBRKR(3,5),DBRKR(3,6),
27663      &    DBRKR(3,7),DBRKR(3,8)
27664       ENDIF
27665
27666       FAC = 1.0D0
27667       IF (MCGENE.EQ.2) THEN
27668
27669 C        CALL PHO_PHIST(-2,SIGMAX)
27670          CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27671
27672       ENDIF
27673
27674       CALL DT_XTIME
27675
27676       RETURN
27677       END
27678
27679 *$ CREATE DT_EVTOUT.FOR
27680 *COPY DT_EVTOUT
27681 *
27682 *===evtout=============================================================*
27683 *
27684       SUBROUTINE DT_EVTOUT(MODE)
27685
27686 ************************************************************************
27687 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27688 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27689 *                    4  plot entries of DTEVT1 and DTEVT2              *
27690 * This version dated 11.12.94 is written by S. Roesler                 *
27691 ************************************************************************
27692
27693       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27694       SAVE
27695
27696       PARAMETER ( LINP = 10 ,
27697      &            LOUT = 6 ,
27698      &            LDAT = 9 )
27699
27700 * event history
27701
27702       PARAMETER (NMXHKK=200000)
27703
27704       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27705      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27706      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27707
27708       DIMENSION IRANGE(NMXHKK)
27709
27710       IF (MODE.EQ.2) RETURN
27711
27712       CALL DT_EVTPLO(IRANGE,MODE)
27713
27714       RETURN
27715       END
27716
27717 *$ CREATE DT_EVTPLO.FOR
27718 *COPY DT_EVTPLO
27719 *
27720 *===evtplo=============================================================*
27721 *
27722       SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27723
27724 ************************************************************************
27725 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27726 *                    2  plot entries of DTEVT1 given by IRANGE         *
27727 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27728 *                    4  plot entries of DTEVT1 and DTEVT2              *
27729 *                    5  plot rejection counter                         *
27730 * This version dated 11.12.94 is written by S. Roesler                 *
27731 ************************************************************************
27732
27733       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27734       SAVE
27735
27736       PARAMETER ( LINP = 10 ,
27737      &            LOUT = 6 ,
27738      &            LDAT = 9 )
27739
27740       CHARACTER*16 CHAU
27741
27742 * event history
27743
27744       PARAMETER (NMXHKK=200000)
27745
27746       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27747      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27748      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27749
27750 * extended event history
27751       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27752      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27753      &                IHIST(2,NMXHKK)
27754
27755 * rejection counter
27756       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27757      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27758      &                IREXCI(3),IRDIFF(2),IRINC
27759
27760       DIMENSION IRANGE(NMXHKK)
27761
27762       IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
27763          WRITE(LOUT,1000)
27764  1000    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTEVT1/',/,
27765      &         15X,'           --------------------------',/,/,
27766      &             '       ST    ID  M1   M2   D1   D2     PX     PY',
27767      &             '     PZ      E       M',/)
27768          DO 1 I=1,NHKK
27769             WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27770      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27771      &                       PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27772      &                       PHKK(5,I)
27773 C           WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27774 C    &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27775 C    &                       PHKK(3,I),PHKK(4,I)
27776 C           WRITE(LOUT,'(4E15.4)')
27777 C    &         VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
27778  1001       FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
27779  1011       FORMAT(I5,I5,I6,4I5,2E15.5)
27780     1    CONTINUE
27781          WRITE(LOUT,*)
27782 C        DO 4 I=1,NHKK
27783 C           WRITE(LOUT,1006) I,ISTHKK(I),
27784 C    &                    VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
27785 C    &                    WHKK(2,I),WHKK(3,I)
27786 C1006       FORMAT(1X,I4,I6,6E10.3)
27787 C   4    CONTINUE
27788       ENDIF
27789
27790       IF (MODE.EQ.2) THEN
27791          WRITE(LOUT,1000)
27792          NC = 0
27793     2    CONTINUE
27794          NC = NC+1
27795          IF (IRANGE(NC).EQ.-100) GOTO 9999
27796          I = IRANGE(NC)
27797          WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27798      &                    JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27799      &                    PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27800      &                    PHKK(5,I)
27801          GOTO 2
27802       ENDIF
27803
27804       IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
27805          WRITE(LOUT,1002)
27806  1002    FORMAT(/,1X,'EVTPLO:',14X,
27807      &         ' content of COMMON /DTEVT1/,/DTEVT2/',/,
27808      &         15X,'        -----------------------------------',/,/,
27809      &             '       ST    ID   M1   M2   D1   D2  IDR  IDXR',
27810      &             ' NOBAM IDCH    M',/)
27811          DO 3 I=1,NHKK
27812 C           IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
27813                KF    = IDHKK(I)
27814                IDCHK = KF/10000
27815                IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
27816      &            (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
27817
27818                CALL PYNAME(KF,CHAU)
27819
27820                WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27821      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27822      &                       IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
27823      &                       PHKK(5,I),CHAU
27824  1003          FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
27825 C           ENDIF
27826     3    CONTINUE
27827       ENDIF
27828
27829       IF (MODE.EQ.5) THEN
27830          WRITE(LOUT,1004)
27831  1004    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTREJC/',/,
27832      &         15X,'           --------------------------',/)
27833          WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
27834      &                    IRSEA,IRCRON
27835  1005    FORMAT(1X,'IRPT   = ',I5,'  IRHHA = ',I5,/,
27836      &          1X,'IRRES  = ',2I5,'  LOMRES = ',I5,'  LOBRES = ',I5,/,
27837      &          1X,'IREMC  = ',10I5,/,
27838      &          1X,'IRFRAG = ',I5,'  IRSEA = ',I5,' IRCRON = ',I5,/)
27839       ENDIF
27840
27841  9999 RETURN
27842       END
27843
27844 *$ CREATE DT_EVTPUT.FOR
27845 *COPY DT_EVTPUT
27846 *
27847 *===evtput=============================================================*
27848 *
27849       SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
27850
27851       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27852       SAVE
27853
27854       PARAMETER ( LINP = 10 ,
27855      &            LOUT = 6 ,
27856      &            LDAT = 9 )
27857
27858       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
27859      &           TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
27860
27861 * event history
27862
27863       PARAMETER (NMXHKK=200000)
27864
27865       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27866      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27867      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27868
27869 * extended event history
27870       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27871      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27872      &                IHIST(2,NMXHKK)
27873
27874 * Lorentz-parameters of the current interaction
27875       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27876      &                UMO,PPCM,EPROJ,PPROJ
27877
27878 * particle properties (BAMJET index convention)
27879       CHARACTER*8  ANAME
27880       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27881      &                IICH(210),IIBAR(210),K1(210),K2(210)
27882
27883 C     IF (MODE.GT.100) THEN
27884 C        WRITE(LOUT,'(1X,A,I5,A,I5)')
27885 C    &        'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
27886 C        NHKK = NHKK-MODE+100
27887 C        RETURN
27888 C     ENDIF
27889       MO1  = M1
27890       MO2  = M2
27891       NHKK = NHKK+1
27892
27893       IF (NHKK.GT.NMXHKK) THEN
27894          WRITE(LOUT,1000) NHKK
27895  1000    FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
27896      &             '! program execution stopped..')
27897          STOP
27898       ENDIF
27899       IF (M1.LT.0) MO1 = NHKK+M1
27900       IF (M2.LT.0) MO2 = NHKK+M2
27901       ISTHKK(NHKK)   = IST
27902       IDHKK(NHKK)    = ID
27903       JMOHKK(1,NHKK) = MO1
27904       JMOHKK(2,NHKK) = MO2
27905       JDAHKK(1,NHKK) = 0
27906       JDAHKK(2,NHKK) = 0
27907       IDRES(NHKK)    = IDR
27908       IDXRES(NHKK)   = IDXR
27909       IDCH(NHKK)     = IDC
27910 ** here we need to do something..
27911       IF (ID.EQ.88888) THEN
27912          IDMO1 = ABS(IDHKK(MO1))
27913          IDMO2 = ABS(IDHKK(MO2))
27914          IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
27915          IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
27916          IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
27917          IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
27918       ELSE
27919          NOBAM(NHKK) = 0
27920       ENDIF
27921       IDBAM(NHKK) = IDT_ICIHAD(ID)
27922       IF (MO1.GT.0) THEN
27923          IF (JDAHKK(1,MO1).NE.0) THEN
27924             JDAHKK(2,MO1) = NHKK
27925          ELSE
27926             JDAHKK(1,MO1) = NHKK
27927          ENDIF
27928       ENDIF
27929       IF (MO2.GT.0) THEN
27930          IF (JDAHKK(1,MO2).NE.0) THEN
27931             JDAHKK(2,MO2) = NHKK
27932          ELSE
27933             JDAHKK(1,MO2) = NHKK
27934          ENDIF
27935       ENDIF
27936 C      IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
27937 C         PTOT   = SQRT(PX**2+PY**2+PZ**2)
27938 C         AM0    = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
27939 C         AMRQ   = AAM(IDBAM(NHKK))
27940 C         AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
27941 C         IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
27942 C     &       (PTOT.GT.ZERO)) THEN
27943 C            DELTA = -AMDIF2/(2.0D0*(E+PTOT))
27944 CC           DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
27945 C            E     = E+DELTA
27946 C            PTOT1 = PTOT-DELTA
27947 C            PX    = PX*PTOT1/PTOT
27948 C            PY    = PY*PTOT1/PTOT
27949 C            PZ    = PZ*PTOT1/PTOT
27950 C         ENDIF
27951 C      ENDIF
27952       PHKK(1,NHKK) = PX
27953       PHKK(2,NHKK) = PY
27954       PHKK(3,NHKK) = PZ
27955       PHKK(4,NHKK) = E
27956       PTOT = SQRT( PX**2+PY**2+PZ**2 )
27957       IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
27958          PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
27959          PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
27960       ELSE
27961          PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
27962 C        IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
27963 C    &      WRITE(LOUT,'(1X,A,G10.3)')
27964 C    &        'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
27965          PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
27966       ENDIF
27967       IDCHK = ID/10000
27968       IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
27969 * special treatment for chains:
27970 *    z coordinate of chain in Lab  = pos. of target nucleon
27971 *    time of chain-creation in Lab = time of passage of projectile
27972 *                                    nucleus at pos. of taget nucleus
27973 C        VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
27974 C        VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
27975          VHKK(1,NHKK) = VHKK(1,MO2)
27976          VHKK(2,NHKK) = VHKK(2,MO2)
27977          VHKK(3,NHKK) = VHKK(3,MO2)
27978          VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
27979 C        WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
27980 C        WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
27981          WHKK(1,NHKK) = WHKK(1,MO1)
27982          WHKK(2,NHKK) = WHKK(2,MO1)
27983          WHKK(3,NHKK) = WHKK(3,MO1)
27984          WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
27985       ELSE
27986          IF (MO1.GT.0) THEN
27987             DO 1 I=1,4
27988                VHKK(I,NHKK) = VHKK(I,MO1)
27989                WHKK(I,NHKK) = WHKK(I,MO1)
27990     1       CONTINUE
27991          ELSE
27992             DO 2 I=1,4
27993                VHKK(I,NHKK) = ZERO
27994                WHKK(I,NHKK) = ZERO
27995     2       CONTINUE
27996          ENDIF
27997       ENDIF
27998
27999       RETURN
28000       END
28001
28002 *$ CREATE DT_CHASTA.FOR
28003 *COPY DT_CHASTA
28004 *
28005 *===chasta=============================================================*
28006 *
28007       SUBROUTINE DT_CHASTA(MODE)
28008
28009 ************************************************************************
28010 * This subroutine performs CHAin STAtistics and checks sequence of     *
28011 * partons in dtevt1 and sorts them with projectile partons coming      *
28012 * first if necessary.                                                  *
28013 *                                                                      *
28014 * This version dated  8.5.00  is written by S. Roesler.                *
28015 ************************************************************************
28016
28017       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28018       SAVE
28019
28020       PARAMETER ( LINP = 10 ,
28021      &            LOUT = 6 ,
28022      &            LDAT = 9 )
28023
28024       CHARACTER*5 CCHTYP
28025
28026 * event history
28027
28028       PARAMETER (NMXHKK=200000)
28029
28030       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28031      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28032      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28033
28034 * extended event history
28035       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28036      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28037      &                IHIST(2,NMXHKK)
28038
28039 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28040       PARAMETER (MAXCHN=10000)
28041       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28042
28043       DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28044      &          CCHTYP(9),ICHSTA(10),ITOT(10)
28045       DATA ICHCFG /1800*0/
28046       DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28047       DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28048       DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28049       DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28050       DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28051       DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28052       DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28053      &              'ad aq',' d ad','ad d ',' g g '/
28054 *
28055 * initialization
28056 *
28057       IF (MODE.EQ.-1) THEN
28058          NCHAIN = 0
28059 *
28060 * loop over DTEVT1 and analyse chain configurations
28061 *
28062       ELSEIF (MODE.EQ.0) THEN
28063          DO 21 IDX=NPOINT(3),NHKK
28064             IDCHK = IDHKK(IDX)/10000
28065             IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28066      &          (IDHKK(IDX).NE.80000).AND.
28067      &          (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28068                IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28069                   WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28070      &                          ' at entry ',IDX
28071                   GOTO 21
28072                ENDIF
28073 *
28074                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28075                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28076                IMO1 = IST1/10
28077                IMO1 = IST1-10*IMO1
28078                IMO2 = IST2/10
28079                IMO2 = IST2-10*IMO2
28080 *   swop parton entries if necessary since we need projectile partons
28081 *   to come first in the common
28082                IF (IMO1.GT.IMO2) THEN
28083                   NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28084                   DO 22 K=1,NPTN/2
28085                      I0 = JMOHKK(1,IDX)-1+K
28086                      I1 = JMOHKK(2,IDX)+1-K
28087                      ITMP = ISTHKK(I0)
28088                      ISTHKK(I0) = ISTHKK(I1)
28089                      ISTHKK(I1) = ITMP
28090                      ITMP = IDHKK(I0)
28091                      IDHKK(I0) = IDHKK(I1)
28092                      IDHKK(I1) = ITMP
28093                      IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28094      &                  JDAHKK(1,JMOHKK(1,I0)) = I1
28095                      IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28096      &                  JDAHKK(2,JMOHKK(1,I0)) = I1
28097                      IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28098      &                  JDAHKK(1,JMOHKK(2,I0)) = I1
28099                      IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28100      &                  JDAHKK(2,JMOHKK(2,I0)) = I1
28101                      IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28102      &                  JDAHKK(1,JMOHKK(1,I1)) = I0
28103                      IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28104      &                  JDAHKK(2,JMOHKK(1,I1)) = I0
28105                      IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28106      &                  JDAHKK(1,JMOHKK(2,I1)) = I0
28107                      IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28108      &                  JDAHKK(2,JMOHKK(2,I1)) = I0
28109                      ITMP = JMOHKK(1,I0)
28110                      JMOHKK(1,I0) = JMOHKK(1,I1)
28111                      JMOHKK(1,I1) = ITMP
28112                      ITMP = JMOHKK(2,I0)
28113                      JMOHKK(2,I0) = JMOHKK(2,I1)
28114                      JMOHKK(2,I1) = ITMP
28115                      ITMP = JDAHKK(1,I0)
28116                      JDAHKK(1,I0) = JDAHKK(1,I1)
28117                      JDAHKK(1,I1) = ITMP
28118                      ITMP = JDAHKK(2,I0)
28119                      JDAHKK(2,I0) = JDAHKK(2,I1)
28120                      JDAHKK(2,I1) = ITMP
28121                      DO 23 J=1,4
28122                         RTMP1 = PHKK(J,I0)
28123                         RTMP2 = VHKK(J,I0)
28124                         RTMP3 = WHKK(J,I0)
28125                         PHKK(J,I0) = PHKK(J,I1)
28126                         VHKK(J,I0) = VHKK(J,I1)
28127                         WHKK(J,I0) = WHKK(J,I1)
28128                         PHKK(J,I1) = RTMP1
28129                         VHKK(J,I1) = RTMP2
28130                         WHKK(J,I1) = RTMP3
28131    23                CONTINUE
28132                      RTMP1 = PHKK(5,I0)
28133                      PHKK(5,I0) = PHKK(5,I1)
28134                      PHKK(5,I1) = RTMP1
28135                      ITMP = IDRES(I0)
28136                      IDRES(I0) = IDRES(I1)
28137                      IDRES(I1) = ITMP
28138                      ITMP = IDXRES(I0)
28139                      IDXRES(I0) = IDXRES(I1)
28140                      IDXRES(I1) = ITMP
28141                      ITMP = NOBAM(I0)
28142                      NOBAM(I0) = NOBAM(I1)
28143                      NOBAM(I1) = ITMP
28144                      ITMP = IDBAM(I0)
28145                      IDBAM(I0) = IDBAM(I1)
28146                      IDBAM(I1) = ITMP
28147                      ITMP = IDCH(I0)
28148                      IDCH(I0) = IDCH(I1)
28149                      IDCH(I1) = ITMP
28150                      ITMP = IHIST(1,I0)
28151                      IHIST(1,I0) = IHIST(1,I1)
28152                      IHIST(1,I1) = ITMP
28153                      ITMP = IHIST(2,I0)
28154                      IHIST(2,I0) = IHIST(2,I1)
28155                      IHIST(2,I1) = ITMP
28156    22             CONTINUE
28157                ENDIF
28158                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28159                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28160 *
28161 *   parton 1 (projectile side)
28162                IF (IST1.EQ.21) THEN
28163                   IDX1 = 1
28164                ELSEIF (IST1.EQ.22) THEN
28165                   IDX1 = 2
28166                ELSEIF (IST1.EQ.31) THEN
28167                   IDX1 = 3
28168                ELSEIF (IST1.EQ.32) THEN
28169                   IDX1 = 4
28170                ELSEIF (IST1.EQ.41) THEN
28171                   IDX1 = 5
28172                ELSEIF (IST1.EQ.42) THEN
28173                   IDX1 = 6
28174                ELSEIF (IST1.EQ.51) THEN
28175                   IDX1 = 7
28176                ELSEIF (IST1.EQ.52) THEN
28177                   IDX1 = 8
28178                ELSEIF (IST1.EQ.61) THEN
28179                   IDX1 = 9
28180                ELSEIF (IST1.EQ.62) THEN
28181                   IDX1 = 10
28182                ELSE
28183 c                 WRITE(LOUT,*)
28184 c    &               ' CHASTA: unknown parton status flag (',
28185 c    &               IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28186                   GOTO 21
28187                ENDIF
28188                ID = IDHKK(JMOHKK(1,IDX))
28189                IF (ABS(ID).LE.4) THEN
28190                   IF (ID.GT.0) THEN
28191                      ITYP1 = 1
28192                   ELSE
28193                      ITYP1 = 2
28194                   ENDIF
28195                ELSEIF (ABS(ID).GE.1000) THEN
28196                   IF (ID.GT.0) THEN
28197                      ITYP1 = 3
28198                   ELSE
28199                      ITYP1 = 4
28200                   ENDIF
28201                ELSEIF (ID.EQ.21) THEN
28202                   ITYP1 = 5
28203                ELSE
28204                   WRITE(LOUT,*)
28205      &               ' CHASTA: inconsistent parton identity (',
28206      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28207                   GOTO 21
28208                ENDIF
28209 *
28210 *   parton 2 (target side)
28211                IF (IST2.EQ.21) THEN
28212                   IDX2 = 1
28213                ELSEIF (IST2.EQ.22) THEN
28214                   IDX2 = 2
28215                ELSEIF (IST2.EQ.31) THEN
28216                   IDX2 = 3
28217                ELSEIF (IST2.EQ.32) THEN
28218                   IDX2 = 4
28219                ELSEIF (IST2.EQ.41) THEN
28220                   IDX2 = 5
28221                ELSEIF (IST2.EQ.42) THEN
28222                   IDX2 = 6
28223                ELSEIF (IST2.EQ.51) THEN
28224                   IDX2 = 7
28225                ELSEIF (IST2.EQ.52) THEN
28226                   IDX2 = 8
28227                ELSEIF (IST2.EQ.61) THEN
28228                   IDX2 = 9
28229                ELSEIF (IST2.EQ.62) THEN
28230                   IDX2 = 10
28231                ELSE
28232 c                 WRITE(LOUT,*)
28233 c    &               ' CHASTA: unknown parton status flag (',
28234 c    &               IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28235                   GOTO 21
28236                ENDIF
28237                ID = IDHKK(JMOHKK(2,IDX))
28238                IF (ABS(ID).LE.4) THEN
28239                   IF (ID.GT.0) THEN
28240                      ITYP2 = 1
28241                   ELSE
28242                      ITYP2 = 2
28243                   ENDIF
28244                ELSEIF (ABS(ID).GE.1000) THEN
28245                   IF (ID.GT.0) THEN
28246                      ITYP2 = 3
28247                   ELSE
28248                      ITYP2 = 4
28249                   ENDIF
28250                ELSEIF (ID.EQ.21) THEN
28251                   ITYP2 = 5
28252                ELSE
28253                   WRITE(LOUT,*)
28254      &               ' CHASTA: inconsistent parton identity (',
28255      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28256                   GOTO 21
28257                ENDIF
28258 *
28259 *   fill counter
28260                ITYPE = ICHTYP(ITYP1,ITYP2)
28261                IF (ITYPE.NE.0) THEN
28262                   ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28263                   NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28264                   ICHCFG(IDX1,IDX2,ITYPE,2) =
28265      &               ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28266
28267                   NCHAIN = NCHAIN+1
28268                   IF (NCHAIN.GT.MAXCHN) THEN
28269                      WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28270      &                  NCHAIN,MAXCHN
28271                      STOP
28272                   ENDIF
28273                   IDXCHN(1,NCHAIN) = IDX
28274                   IDXCHN(2,NCHAIN) = ITYPE
28275                ELSE
28276                   WRITE(LOUT,*)
28277      &               ' CHASTA: inconsistent chain at entry ',IDX
28278                   GOTO 21
28279                ENDIF
28280             ENDIF
28281    21    CONTINUE
28282 *
28283 * write statistics to output unit
28284 *
28285       ELSEIF (MODE.EQ.1) THEN
28286          WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28287          DO 31 I=1,10
28288             WRITE(LOUT,'(/,2A)')
28289      &         ' -----------------------------------------',
28290      &         '------------------------------------'
28291             WRITE(LOUT,'(2A)')
28292      &         ' p\\t         21     22     31     32     41',
28293      &         '     42     51     52     61     62'
28294             WRITE(LOUT,'(2A)')
28295      &         ' -----------------------------------------',
28296      &         '------------------------------------'
28297             DO 32 J=1,10
28298                ITOT(J) = 0
28299                DO 33 K=1,9
28300                   ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28301    33          CONTINUE
28302    32       CONTINUE
28303             WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28304             DO 34 K=1,9
28305                ISUM = 0
28306                DO 35 J=1,10
28307                   ISUM = ISUM+ICHCFG(I,J,K,1)
28308    35          CONTINUE
28309                IF (ISUM.GT.0)
28310      &            WRITE(LOUT,'(1X,A5,2X,10I7)')
28311      &               CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28312    34       CONTINUE
28313 C           WRITE(LOUT,'(2A)')
28314 C    &         ' -----------------------------------------',
28315 C    &         '-------------------------------'
28316    31    CONTINUE
28317 *
28318       ELSE
28319          WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28320          STOP
28321       ENDIF
28322
28323       RETURN
28324       END
28325 *$ CREATE PHO_PHIST.FOR
28326 *COPY PHO_PHIST
28327 *
28328 *===pohist=============================================================*
28329 *
28330       SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28331
28332       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28333       SAVE
28334
28335       PARAMETER ( LINP = 10 ,
28336      &            LOUT = 6 ,
28337      &            LDAT = 9 )
28338
28339       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28340
28341 * Glauber formalism: cross sections
28342       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28343      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28344      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28345      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28346      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28347      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28348      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28349      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28350      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28351      &                BSLOPE,NEBINI,NQBINI
28352
28353       ILAB = 0
28354       IF (IMODE.EQ.10) THEN
28355          IMODE = 1
28356          ILAB  = 1
28357       ENDIF
28358       IF (ABS(IMODE).LT.1000) THEN
28359 * PHOJET-statistics
28360 C        CALL POHISX(IMODE,WEIGHT)
28361          IF (IMODE.EQ.-1) THEN
28362             MODE = 1
28363             XSTOT(1,1,1) = WEIGHT
28364          ENDIF
28365          IF (IMODE.EQ. 1) MODE = 2
28366          IF (IMODE.EQ.-2) MODE = 3
28367          IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28368 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28369 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28370          CALL DT_HISTOG(MODE)
28371          CALL DT_USRHIS(MODE)
28372       ELSE
28373 * DTUNUC-statistics
28374          MODE = IMODE/1000
28375 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28376 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28377          CALL DT_HISTOG(MODE)
28378          CALL DT_USRHIS(MODE)
28379       ENDIF
28380
28381       RETURN
28382       END
28383
28384 *$ CREATE DT_SWPPHO.FOR
28385 *COPY DT_SWPPHO
28386 *
28387 *===swppho=============================================================*
28388 *
28389       SUBROUTINE DT_SWPPHO(ILAB)
28390
28391       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28392       SAVE
28393
28394       PARAMETER ( LINP = 10 ,
28395      &            LOUT = 6 ,
28396      &            LDAT = 9 )
28397
28398       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28399
28400       LOGICAL LSTART
28401
28402 * event history
28403
28404       PARAMETER (NMXHKK=200000)
28405
28406       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28407      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28408      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28409
28410 * extended event history
28411       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28412      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28413      &                IHIST(2,NMXHKK)
28414
28415 * flags for input different options
28416       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28417       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28418      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28419
28420 * properties of photon/lepton projectiles
28421       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28422
28423 **PHOJET105a
28424 C     PARAMETER (NMXHEP=2000)
28425 C     COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28426 C    &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28427 C     COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28428 C     COMMON /PLASAV/ PLAB
28429 **PHOJET110
28430 C  standard particle data interface
28431       INTEGER NMXHEP
28432
28433       PARAMETER (NMXHEP=4000)
28434
28435       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28436       DOUBLE PRECISION PHEP,VHEP
28437       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28438      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28439      &                VHEP(4,NMXHEP)
28440 C  extension to standard particle data interface (PHOJET specific)
28441       INTEGER IMPART,IPHIST,ICOLOR
28442       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28443
28444 C  global event kinematics and particle IDs
28445       INTEGER IFPAP,IFPAB
28446       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28447       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28448 **
28449       DATA ICOUNT/0/
28450
28451       DATA LSTART /.TRUE./
28452
28453 C     IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28454       IF ((IFRAME.EQ.1).AND.LSTART) THEN
28455          UMO  = ECM
28456          ELA  = ZERO
28457          PLA  = ZERO
28458          IDP  = IDT_ICIHAD(IFPAP(1))
28459          IDT  = IDT_ICIHAD(IFPAP(2))
28460          VIRT = PVIRT(1)
28461          CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28462          PLAB = PLA
28463          LSTART = .FALSE.
28464       ENDIF
28465
28466       NHKK   = 0
28467       ICOUNT = ICOUNT+1
28468 C     NEVHKK = NEVHEP
28469       NEVHKK = ICOUNT
28470       IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28471       DO 1 I=3,NHEP
28472          IF (ISTHEP(I).EQ.1) THEN
28473             NHKK = NHKK+1
28474             ISTHKK(NHKK) = 1
28475             IDHKK(NHKK)  = IDHEP(I)
28476             JMOHKK(1,NHKK) = 0
28477             JMOHKK(2,NHKK) = 0
28478             JDAHKK(1,NHKK) = 0
28479             JDAHKK(2,NHKK) = 0
28480             DO 2 K=1,4
28481                PHKK(K,NHKK) = PHEP(K,I)
28482                VHKK(K,NHKK) = ZERO
28483                WHKK(K,NHKK) = ZERO
28484     2       CONTINUE
28485             IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28486      &         CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28487      &                    PHKK(3,NHKK),PHKK(4,NHKK),-3)
28488             PHKK(5,NHKK) = PHEP(5,I)
28489             IDRES(NHKK)  = 0
28490             IDXRES(NHKK) = 0
28491             NOBAM(NHKK)  = 0
28492             IDBAM(NHKK)  = IDT_ICIHAD(IDHEP(I))
28493             IDCH(NHKK)   = 0
28494          ENDIF
28495     1 CONTINUE
28496
28497       RETURN
28498       END
28499
28500 *$ CREATE DT_HISTOG.FOR
28501 *COPY DT_HISTOG
28502 *
28503 *===histog=============================================================*
28504 *
28505       SUBROUTINE DT_HISTOG(MODE)
28506
28507 ************************************************************************
28508 * This version dated 25.03.96 is written by S. Roesler                 *
28509 ************************************************************************
28510
28511       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28512       SAVE
28513
28514       PARAMETER ( LINP = 10 ,
28515      &            LOUT = 6 ,
28516      &            LDAT = 9 )
28517
28518       LOGICAL LFSP,LRNL
28519
28520 * event history
28521
28522       PARAMETER (NMXHKK=200000)
28523
28524       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28525      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28526      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28527
28528 * extended event history
28529       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28530      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28531      &                IHIST(2,NMXHKK)
28532
28533 * event flag used for histograms
28534       COMMON /DTNORM/ ICEVT,IEVHKK
28535
28536 * flags for activated histograms
28537       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28538
28539       IEVHKK = NEVHKK
28540       GOTO (1,2,3) MODE
28541
28542 *------------------------------------------------------------------
28543 * initialization
28544     1 CONTINUE
28545       ICEVT = 0
28546       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28547       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28548
28549       RETURN
28550 *------------------------------------------------------------------
28551 * filling of histogram with event-record
28552     2 CONTINUE
28553       ICEVT = ICEVT+1
28554
28555       DO 20 I=1,NHKK
28556          CALL DT_SWPFSP(I,LFSP,LRNL)
28557          IF (LFSP) THEN
28558             IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28559             IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28560          ENDIF
28561          IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28562    20 CONTINUE
28563       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28564
28565       RETURN
28566 *------------------------------------------------------------------
28567 * output
28568     3 CONTINUE
28569       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28570       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28571
28572       RETURN
28573       END
28574
28575 *$ CREATE DT_SWPFSP.FOR
28576 *COPY DT_SWPFSP
28577 *
28578 *===swpfsp=============================================================*
28579 *
28580       SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28581
28582       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28583       SAVE
28584       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28585       PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28586      &           PI   =TWOPI/TWO,
28587      &           BOG  =TWOPI/360.0D0)
28588
28589 * event history
28590
28591       PARAMETER (NMXHKK=200000)
28592
28593       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28594      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28595      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28596
28597 * extended event history
28598       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28599      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28600      &                IHIST(2,NMXHKK)
28601
28602 * particle properties (BAMJET index convention)
28603       CHARACTER*8  ANAME
28604       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28605      &                IICH(210),IIBAR(210),K1(210),K2(210)
28606
28607 * Lorentz-parameters of the current interaction
28608       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28609      &                UMO,PPCM,EPROJ,PPROJ
28610
28611 * flags for input different options
28612       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28613       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28614      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28615
28616 *      INCLUDE '(DIMPAR)'
28617 *     Taken from FLUKA
28618       PARAMETER ( MXXRGN =20000 )
28619       PARAMETER ( MXXMDF =  710 )
28620       PARAMETER ( MXXMDE =  702 )
28621       PARAMETER ( MFSTCK =40000 )
28622       PARAMETER ( MESTCK =  100 )
28623       PARAMETER ( MOSTCK = 2000 )
28624       PARAMETER ( MXPRSN =  100 )
28625       PARAMETER ( MXPDPM =  800 )
28626       PARAMETER ( MXPSCS =30000 )
28627       PARAMETER ( MXGLWN =  300 )
28628       PARAMETER ( MXOUTU =   50 )
28629       PARAMETER ( NALLWP =   64 )
28630       PARAMETER ( NELEMX =   80 )
28631       PARAMETER ( MPDPDX =   18 )
28632       PARAMETER ( MXHTTR =  260 )
28633       PARAMETER ( MXSEAX =   20 )
28634       PARAMETER ( MXHTNC = MXSEAX + 1 )
28635       PARAMETER ( ICOMAX = 2400 )
28636       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
28637       PARAMETER ( NSTBIS =  304 )
28638       PARAMETER ( NQSTIS =   46 )
28639       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
28640       PARAMETER ( MXPABL =  120 )
28641       PARAMETER ( IDMAXP =  450 )
28642       PARAMETER ( IDMXDC = 2000 )
28643       PARAMETER ( MXMCIN =  410 )
28644       PARAMETER ( IHYPMX =    4 )
28645       PARAMETER ( MKBMX1 =   11 )
28646       PARAMETER ( MKBMX2 =   11 )
28647       PARAMETER ( MXIRRD = 2500 )
28648       PARAMETER ( MXTRDC = 1500 )
28649       PARAMETER ( NKTL   =   17 )
28650       PARAMETER ( NBLNMX = 40000000 )
28651
28652 *      INCLUDE '(PAREVT)'
28653 *     Taken from FLUKA
28654       PARAMETER ( FRDIFF = 0.2D+00 )
28655       PARAMETER ( ETHSEA = 1.0D+00 )
28656 *
28657       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28658      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
28659      &        LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
28660      &        LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
28661       COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
28662      &                  LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28663      &                  LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28664      &                  LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
28665      &                  LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
28666      &                  LVP2XX, LV2XNW, LNWV2X, LEVFIN
28667
28668 * temporary storage for one final state particle
28669       LOGICAL LFRAG,LGREY,LBLACK
28670       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28671      &                SINTHE,COSTHE,THETA,THECMS,
28672      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28673      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28674      &                LFRAG,LGREY,LBLACK
28675
28676       LOGICAL LFSP,LRNL
28677
28678       LFSP = .FALSE.
28679       LRNL = .FALSE.
28680       ISTRNL = 1000
28681       MULDEF = 1
28682       IF (LEVPRT) ISTRNL = 1001
28683
28684       IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28685          IST    = ISTHKK(IDX)
28686          IDPDG  = IDHKK(IDX)
28687          LFRAG  = .FALSE.
28688          IF (IDHKK(IDX).LT.80000) THEN
28689             IDBJT  = IDBAM(IDX)
28690             IBARY  = IIBAR(IDBJT)
28691             ICHAR  = IICH(IDBJT)
28692             AMASS  = AAM(IDBJT)
28693          ELSEIF (IDHKK(IDX).EQ.80000) THEN
28694             IDBJT  = 0
28695             IBARY  = IDRES(IDX)
28696             ICHAR  = IDXRES(IDX)
28697             AMASS  = PHKK(5,IDX)
28698             INUT   = IBARY-ICHAR
28699             IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28700             IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28701             IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28702             IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28703             IF (IDBJT.EQ.0) LFRAG = .TRUE.
28704          ELSE
28705             GOTO 9999
28706          ENDIF
28707          PE     = PHKK(4,IDX)
28708          PX     = PHKK(1,IDX)
28709          PY     = PHKK(2,IDX)
28710          PZ     = PHKK(3,IDX)
28711          PT2    = PX**2+PY**2
28712          PT     = SQRT(PT2)
28713          PTOT   = SQRT(PT2+PZ**2)
28714          SINTHE = PT/MAX(PTOT,TINY14)
28715          COSTHE = PZ/MAX(PTOT,TINY14)
28716          IF (COSTHE.GT.ONE) THEN
28717             THETA = ZERO
28718          ELSEIF (COSTHE.LT.-ONE) THEN
28719             THETA = TWOPI/2.0D0
28720          ELSE
28721             THETA = ACOS(COSTHE)
28722          ENDIF
28723          EKIN   = PE-AMASS
28724 **sr 15.4.96 new E_t-definition
28725          IF (IBARY.GT.0) THEN
28726             ET = EKIN*SINTHE
28727          ELSEIF (IBARY.LT.0) THEN
28728             ET = (EKIN+TWO*AMASS)*SINTHE
28729          ELSE
28730             ET = PE*SINTHE
28731          ENDIF
28732 **
28733          XLAB   = PZ/MAX(PPROJ,TINY14)
28734 C        XLAB   = PE/MAX(EPROJ,TINY14)
28735          BETA   = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28736      &                     *(ONE+AMASS/MAX(PE,TINY14)) ))
28737          PPLUS  = PE+PZ
28738          PMINUS = PE-PZ
28739          IF (PMINUS.GT.TINY14) THEN
28740             YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28741          ELSE
28742             YY = 100.0D0
28743          ENDIF
28744          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28745             ETA = -LOG(TAN(THETA/TWO))
28746          ELSE
28747             ETA = 100.0D0
28748          ENDIF
28749          IF (IFRAME.EQ.1) THEN
28750             CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28751             PPLUS  = EECMS+PZCMS
28752             PMINUS = EECMS-PZCMS
28753             IF ((PPLUS*PMINUS).GT.TINY14) THEN
28754                YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28755             ELSE
28756                YYCMS = 100.0D0
28757             ENDIF
28758             PTOTCM = SQRT(PT2+PZCMS**2)
28759             COSTH = PZCMS/MAX(PTOTCM,TINY14)
28760             IF (COSTH.GT.ONE) THEN
28761                THECMS = ZERO
28762             ELSEIF (COSTH.LT.-ONE) THEN
28763                THECMS = TWOPI/2.0D0
28764             ELSE
28765                THECMS = ACOS(COSTH)
28766             ENDIF
28767             IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28768                ETACMS = -LOG(TAN(THECMS/TWO))
28769             ELSE
28770                ETACMS = 100.0D0
28771             ENDIF
28772             XF = PZCMS/MAX(PPCM,TINY14)
28773             THECMS = THECMS/BOG
28774          ELSE
28775             PZCMS  = PZ
28776             EECMS  = PE
28777             YYCMS  = YY
28778             ETACMS = ETA
28779             XF     = XLAB
28780             THECMS = THETA/BOG
28781          ENDIF
28782          THETA  = THETA/BOG
28783
28784 * set flag for "grey/black"
28785          LGREY  = .FALSE.
28786          LBLACK = .FALSE.
28787          EK     = EKIN
28788          IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28789          IF (MULDEF.EQ.1) THEN
28790 *  EMU01-Def.
28791             IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28792      &                              (EK.LE.375.0D-3)      ).OR.
28793      &           ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28794      &                              (EK.LE. 56.0D-3)      ).OR.
28795      &           ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28796      &                              (EK.LE. 56.0D-3)      ).OR.
28797      &           ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28798      &                              (EK.LE.198.0D-3)      ).OR.
28799      &           ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28800      &                              (EK.LE.198.0D-3)      ).OR.
28801      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28802      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28803      &             (IDBJT.NE.16).AND.
28804      &             (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)    ) )
28805      &         LGREY = .TRUE.
28806             IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28807      &           ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28808      &           ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28809      &           ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28810      &           ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28811      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28812      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28813      &             (IDBJT.NE.16).AND.(BETA.LE.0.23D0)  ) )
28814      &         LBLACK = .TRUE.
28815          ELSE
28816 *  common Def.
28817             IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28818             IF (BETA.LE.0.23D0) LBLACK=.TRUE.
28819          ENDIF
28820          LFSP = .TRUE.
28821       ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
28822          IST    = ISTHKK(IDX)
28823          IDPDG  = IDHKK(IDX)
28824          LFRAG  = .TRUE.
28825          IDBJT  = 0
28826          IBARY  = IDRES(IDX)
28827          ICHAR  = IDXRES(IDX)
28828          AMASS  = PHKK(5,IDX)
28829          PE     = PHKK(4,IDX)
28830          PX     = PHKK(1,IDX)
28831          PY     = PHKK(2,IDX)
28832          PZ     = PHKK(3,IDX)
28833          PT2    = PX**2+PY**2
28834          PT     = SQRT(PT2)
28835          PTOT   = SQRT(PT2+PZ**2)
28836          SINTHE = PT/MAX(PTOT,TINY14)
28837          COSTHE = PZ/MAX(PTOT,TINY14)
28838          IF (COSTHE.GT.ONE) THEN
28839             THETA = ZERO
28840          ELSEIF (COSTHE.LT.-ONE) THEN
28841             THETA = TWOPI/2.0D0
28842          ELSE
28843             THETA  = ACOS(COSTHE)
28844          ENDIF
28845          EKIN   = PE-AMASS
28846 **sr 15.4.96 new E_t-definition
28847 C        ET     = PE*SINTHE
28848          ET     = EKIN*SINTHE
28849 **
28850          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28851             ETA = -LOG(TAN(THETA/TWO))
28852          ELSE
28853             ETA = 100.0D0
28854          ENDIF
28855          THETA  = THETA/BOG
28856          LRNL   = .TRUE.
28857       ENDIF
28858
28859  9999 CONTINUE
28860       RETURN
28861       END
28862
28863 *$ CREATE DT_HIMULT.FOR
28864 *COPY DT_HIMULT
28865 *
28866 *===himult=============================================================*
28867 *
28868       SUBROUTINE DT_HIMULT(MODE)
28869
28870 ************************************************************************
28871 * Tables of average energies/multiplicities.                           *
28872 * This version dated 30.08.2000 is written by S. Roesler               *
28873 ************************************************************************
28874
28875       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28876       SAVE
28877
28878       PARAMETER ( LINP = 10 ,
28879      &            LOUT = 6 ,
28880      &            LDAT = 9 )
28881
28882       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28883
28884       PARAMETER (SWMEXP=1.7D0)
28885
28886       CHARACTER*8 ANAMEH(4)
28887
28888 * particle properties (BAMJET index convention)
28889       CHARACTER*8  ANAME
28890       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28891      &                IICH(210),IIBAR(210),K1(210),K2(210)
28892
28893 * temporary storage for one final state particle
28894       LOGICAL LFRAG,LGREY,LBLACK
28895       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28896      &                SINTHE,COSTHE,THETA,THECMS,
28897      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28898      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28899      &                LFRAG,LGREY,LBLACK
28900
28901 * event flag used for histograms
28902       COMMON /DTNORM/ ICEVT,IEVHKK
28903
28904 * Lorentz-parameters of the current interaction
28905       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28906      &                UMO,PPCM,EPROJ,PPROJ
28907
28908       PARAMETER (NOPART=210)
28909       DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
28910      &          AVPT(4,NOPART),IAVPT(4,NOPART)
28911       DATA ANAMEH /'DEUTERON','3-H     ','3-HE    ','4-HE    '/
28912
28913       GOTO (1,2,3) MODE
28914
28915 *------------------------------------------------------------------
28916 * initialization
28917     1 CONTINUE
28918       DO 10 I=1,NOPART
28919          DO 11 J=1,4
28920             AVMULT(J,I) = ZERO
28921             AVE(J,I)    = ZERO
28922             AVSWM(J,I)  = ZERO
28923             AVPT(J,I)   = ZERO
28924             IAVPT(J,I)  = 0
28925    11    CONTINUE
28926    10 CONTINUE
28927
28928       RETURN
28929
28930 *------------------------------------------------------------------
28931 * filling of histogram with event-record
28932     2 CONTINUE
28933       IF (PE.LT.0.0D0) THEN
28934          WRITE(LOUT,*) ' HIMULT:  PE < 0 ! ',PE
28935          RETURN
28936       ENDIF
28937       IF (.NOT.LFRAG) THEN
28938          IVEL = 2
28939          IF (LGREY)  IVEL = 3
28940          IF (LBLACK) IVEL = 4
28941          AVE(1,IDBJT)       = AVE(1,IDBJT)   +PE
28942          AVE(IVEL,IDBJT)    = AVE(IVEL,IDBJT)+PE
28943          AVPT(1,IDBJT)     = AVPT(1,IDBJT)   +PT
28944          AVPT(IVEL,IDBJT)  = AVPT(IVEL,IDBJT)+PT
28945          IAVPT(1,IDBJT)    = IAVPT(1,IDBJT)   +1
28946          IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
28947          AVSWM(1,IDBJT)     = AVSWM(1,IDBJT)   +PE**SWMEXP
28948          AVSWM(IVEL,IDBJT)  = AVSWM(IVEL,IDBJT)+PE**SWMEXP
28949          AVMULT(1,IDBJT)    = AVMULT(1,IDBJT)   +ONE
28950          AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
28951          IF (IDBJT.LT.116) THEN
28952 *   total energy, multiplicity
28953             AVE(1,30)       = AVE(1,30)   +PE
28954             AVE(IVEL,30)    = AVE(IVEL,30)+PE
28955             AVPT(1,30)     = AVPT(1,30)   +PT
28956             AVPT(IVEL,30)  = AVPT(IVEL,30)+PT
28957             IAVPT(1,30)    = IAVPT(1,30)   +1
28958             IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
28959             AVSWM(1,30)     = AVSWM(1,30)+PE**SWMEXP
28960             AVSWM(IVEL,30)  = AVSWM(IVEL,30)+PE**SWMEXP
28961             AVMULT(1,30)    = AVMULT(1,30)   +ONE
28962             AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
28963 *   charged energy, multiplicity
28964             IF (ICHAR.LT.0) THEN
28965                AVE(1,26)       = AVE(1,26)   +PE
28966                AVE(IVEL,26)    = AVE(IVEL,26)+PE
28967                AVPT(1,26)     = AVPT(1,26)   +PT
28968                AVPT(IVEL,26)  = AVPT(IVEL,26)+PT
28969                IAVPT(1,26)    = IAVPT(1,26)   +1
28970                IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
28971                AVSWM(1,26)     = AVSWM(1,26)   +PE**SWMEXP
28972                AVSWM(IVEL,26)  = AVSWM(IVEL,26)+PE**SWMEXP
28973                AVMULT(1,26)    = AVMULT(1,26)   +ONE
28974                AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
28975             ENDIF
28976             IF (ICHAR.NE.0) THEN
28977                AVE(1,27)       = AVE(1,27)   +PE
28978                AVE(IVEL,27)    = AVE(IVEL,27)+PE
28979                AVPT(1,27)     = AVPT(1,27)   +PT
28980                AVPT(IVEL,27)  = AVPT(IVEL,27)+PT
28981                IAVPT(1,27)    = IAVPT(1,27)   +1
28982                IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
28983                AVSWM(1,27)     = AVSWM(1,27)   +PE**SWMEXP
28984                AVSWM(IVEL,27)  = AVSWM(IVEL,27)+PE**SWMEXP
28985                AVMULT(1,27)    = AVMULT(1,27)   +ONE
28986                AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
28987             ENDIF
28988          ENDIF
28989       ENDIF
28990
28991       RETURN
28992
28993 *------------------------------------------------------------------
28994 * output
28995     3 CONTINUE
28996       WRITE(LOUT,3000)
28997  3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
28998      &       29X,'---------------------',/)
28999       IF (MULDEF.EQ.1) THEN
29000          WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
29001       ELSE
29002          BETGRE = 0.7D0
29003          BETBLC = 0.23D0
29004          WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29005  3002    FORMAT(1X,'fast:  beta > ',F4.2,'    grey:  ',F4.2,' > beta > '
29006      &          ,F4.2,'    black:  beta < ',F4.2,/)
29007       ENDIF
29008       WRITE(LOUT,3003) SWMEXP
29009  3003 FORMAT(1X,'particle    |',12X,'average multiplicity',/,
29010      &      13X,'|     total         fast',
29011 C    &      '       grey     black      K      f(',F3.1,')',/,1X,
29012      &      '       grey     black    <pt>     f(',F3.1,')',/,1X,
29013      &      '------------+--------------',
29014      &      '-------------------------------------------------')
29015       DO 30 I=1,NOPART
29016          DO 31 J=1,4
29017             AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29018             AVE(J,I)    = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29019             AVPT(J,I)   = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29020             AVSWM(J,I)  = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29021    31    CONTINUE
29022          IF (I.LE.115) THEN
29023             WRITE(LOUT,3004) ANAME(I),I,
29024      &                       AVMULT(1,I),AVMULT(2,I),
29025      &                       AVMULT(3,I),AVMULT(4,I),
29026 C    &                       AVE(1,I),AVSWM(1,I)
29027      &                       AVPT(1,I),AVSWM(1,I)
29028          ELSEIF (I.LE.119) THEN
29029             WRITE(LOUT,3004) ANAMEH(I-115),I,
29030      &                       AVMULT(1,I),AVMULT(2,I),
29031      &                       AVMULT(3,I),AVMULT(4,I),
29032 C    &                       AVE(1,I),AVSWM(1,I)
29033      &                       AVPT(1,I),AVSWM(1,I)
29034          ENDIF
29035  3004    FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29036    30 CONTINUE
29037 **temporary
29038 C     WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29039 C    &               AVMULT(3,27)+AVMULT(4,27)
29040 **
29041
29042       RETURN
29043       END
29044
29045 *$ CREATE DT_HISTAT.FOR
29046 *COPY DT_HISTAT
29047 *
29048 *===histat=============================================================*
29049 *
29050       SUBROUTINE DT_HISTAT(IDX,MODE)
29051
29052 ************************************************************************
29053 * This version dated 26.02.96 is written by S. Roesler                 *
29054 *                                                                      *
29055 * Last change 27.12.2006 by S. Roesler.                                *
29056 ************************************************************************
29057
29058       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29059       SAVE
29060
29061       PARAMETER ( LINP = 10 ,
29062      &            LOUT = 6 ,
29063      &            LDAT = 9 )
29064
29065       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29066       PARAMETER (NDIM=199)
29067
29068 * event history
29069
29070       PARAMETER (NMXHKK=200000)
29071
29072       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29073      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29074      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29075
29076 * extended event history
29077       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29078      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29079      &                IHIST(2,NMXHKK)
29080
29081 * particle properties (BAMJET index convention)
29082       CHARACTER*8  ANAME
29083       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29084      &                IICH(210),IIBAR(210),K1(210),K2(210)
29085
29086       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29087
29088 * Glauber formalism: cross sections
29089       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29090      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29091      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29092      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29093      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29094      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29095      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29096      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29097      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29098      &                BSLOPE,NEBINI,NQBINI
29099
29100 * emulsion treatment
29101       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29102      &                NCOMPO,IEMUL
29103
29104 * properties of interacting particles
29105       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29106
29107 * rejection counter
29108       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29109      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29110      &                IREXCI(3),IRDIFF(2),IRINC
29111
29112 * statistics: residual nuclei
29113       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29114      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29115      &                NINCST(2,4),NINCEV(2),
29116      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29117      &                NRESPB(2),NRESCH(2),NRESEV(4),
29118      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29119      &                NEVAFI(2,2)
29120
29121 * parameter for intranuclear cascade
29122       LOGICAL LPAULI
29123       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29124
29125 *      INCLUDE '(DIMPAR)'
29126 *     Taken from FLUKA
29127       PARAMETER ( MXXRGN =20000 )
29128       PARAMETER ( MXXMDF =  710 )
29129       PARAMETER ( MXXMDE =  702 )
29130       PARAMETER ( MFSTCK =40000 )
29131       PARAMETER ( MESTCK =  100 )
29132       PARAMETER ( MOSTCK = 2000 )
29133       PARAMETER ( MXPRSN =  100 )
29134       PARAMETER ( MXPDPM =  800 )
29135       PARAMETER ( MXPSCS =30000 )
29136       PARAMETER ( MXGLWN =  300 )
29137       PARAMETER ( MXOUTU =   50 )
29138       PARAMETER ( NALLWP =   64 )
29139       PARAMETER ( NELEMX =   80 )
29140       PARAMETER ( MPDPDX =   18 )
29141       PARAMETER ( MXHTTR =  260 )
29142       PARAMETER ( MXSEAX =   20 )
29143       PARAMETER ( MXHTNC = MXSEAX + 1 )
29144       PARAMETER ( ICOMAX = 2400 )
29145       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
29146       PARAMETER ( NSTBIS =  304 )
29147       PARAMETER ( NQSTIS =   46 )
29148       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
29149       PARAMETER ( MXPABL =  120 )
29150       PARAMETER ( IDMAXP =  450 )
29151       PARAMETER ( IDMXDC = 2000 )
29152       PARAMETER ( MXMCIN =  410 )
29153       PARAMETER ( IHYPMX =    4 )
29154       PARAMETER ( MKBMX1 =   11 )
29155       PARAMETER ( MKBMX2 =   11 )
29156       PARAMETER ( MXIRRD = 2500 )
29157       PARAMETER ( MXTRDC = 1500 )
29158       PARAMETER ( NKTL   =   17 )
29159       PARAMETER ( NBLNMX = 40000000 )
29160
29161 *      INCLUDE '(PAREVT)'
29162 *     Taken from FLUKA
29163       PARAMETER ( FRDIFF = 0.2D+00 )
29164       PARAMETER ( ETHSEA = 1.0D+00 )
29165 *
29166       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29167      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
29168      &        LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
29169      &        LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
29170       COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
29171      &                  LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29172      &                  LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29173      &                  LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
29174      &                  LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
29175      &                  LVP2XX, LV2XNW, LNWV2X, LEVFIN
29176
29177 *      INCLUDE '(FRBKCM)'
29178 *     Taken from FLUKA
29179 *  Maximum number of fragments to be emitted:
29180       PARAMETER ( MXFFBK =     6 )
29181       PARAMETER ( MXZFBK =    10 )
29182       PARAMETER ( MXNFBK =    12 )
29183       PARAMETER ( MXAFBK =    16 )
29184       PARAMETER ( MXASST =    25 )
29185       PARAMETER ( NXAFBK = MXAFBK + 1 )
29186       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
29187       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
29188       PARAMETER ( MXPSST =   700 )
29189 *  Maximum number of pre-computed break-up combinations
29190       PARAMETER ( MXPPFB = 42500 )
29191 *  Maximum number of break-up combinations, including special
29192 *  run-time ones:
29193       PARAMETER ( MXPSFB = 43000 )
29194 *  Base for J multiplicity encoding:
29195       PARAMETER ( IBFRBK =    73 )
29196 *  Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
29197 *  it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
29198 *  ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
29199 *  --> Ibfrbk^(Jpwfbx+1) < 2100000000
29200       PARAMETER ( JPWFBX =     4 )
29201       LOGICAL LFRMBK, LNCMSS
29202       COMMON / FRBKCM /  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29203      &          WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
29204      &          SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
29205      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
29206      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
29207      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29208      &          IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
29209      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29210      &          IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
29211      &          IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
29212
29213 *      INCLUDE '(EVAFLG)'
29214 *     Taken from FLUKA
29215       LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29216      &        LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29217      &        LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29218      &        LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29219       COMMON / EVAFLG /     BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
29220      &        ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
29221      &        MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
29222      &        MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
29223      &        LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29224      &        LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29225      &        LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29226      &        LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29227
29228 * temporary storage for one final state particle
29229       LOGICAL LFRAG,LGREY,LBLACK
29230       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29231      &                SINTHE,COSTHE,THETA,THECMS,
29232      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29233      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29234      &                LFRAG,LGREY,LBLACK
29235
29236 * event flag used for histograms
29237       COMMON /DTNORM/ ICEVT,IEVHKK
29238
29239 * statistics: double-Pomeron exchange
29240       COMMON /DTFLG2/ INTFLG,IPOPO
29241
29242       DIMENSION EMUSAM(NCOMPX)
29243
29244       CHARACTER*13 CMSG(3)
29245       DATA CMSG /'not requested','not requested','not requested'/
29246
29247       GOTO (1,2,3,4,5) MODE
29248
29249 *------------------------------------------------------------------
29250 * initialization
29251     1 CONTINUE
29252 *  emulsion treatment
29253       IF (NCOMPO.GT.0) THEN
29254          DO 10 I=1,NCOMPX
29255             EMUSAM(I) = ZERO
29256    10    CONTINUE
29257       ENDIF
29258 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29259       NINCGE = 0
29260       DO 11 I=1,2
29261          EXCDPM(I)   = ZERO
29262          EXCDPM(I+2) = ZERO
29263          EXCEVA(I)   = ZERO
29264          NINCWO(I)   = 0
29265          NINCEV(I)   = 0
29266          NRESTO(I)   = 0
29267          NRESPR(I)   = 0
29268          NRESNU(I)   = 0
29269          NRESBA(I)   = 0
29270          NRESPB(I)   = 0
29271          NRESCH(I)   = 0
29272          NRESEV(I)   = 0
29273          NRESEV(I+2) = 0
29274          NEVAGA(I)   = 0
29275          NEVAHT(I)   = 0
29276          NEVAFI(1,I) = 0
29277          NEVAFI(2,I) = 0
29278          DO 12 J=1,6
29279             IF (J.LE.2) NINCHR(I,J) = 0
29280             IF (J.LE.3) NINCCO(I,J) = 0
29281             IF (J.LE.4) NINCST(I,J) = 0
29282             NEVA(I,J) = 0
29283    12    CONTINUE
29284          DO 13 J=1,210
29285             NEVAHY(1,I,J) = 0
29286             NEVAHY(2,I,J) = 0
29287    13    CONTINUE
29288    11 CONTINUE
29289       MAXGEN = 0
29290 **dble Po statistics.
29291       KPOPO = 0
29292
29293       RETURN
29294 *------------------------------------------------------------------
29295 * filling of histogram with event-record
29296     2 CONTINUE
29297       IF (IST.EQ.-1) THEN
29298          IF (.NOT.LFRAG) THEN
29299             IF (IDPDG.EQ.2212) THEN
29300                NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29301             ELSEIF (IDPDG.EQ.2112) THEN
29302                NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29303             ELSEIF (IDPDG.EQ.22) THEN
29304                NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29305             ELSEIF (IDPDG.EQ.80000) THEN
29306                IF (IDBJT.EQ.116) THEN
29307                   NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29308                ELSEIF (IDBJT.EQ.117) THEN
29309                   NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29310                ELSEIF (IDBJT.EQ.118) THEN
29311                   NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29312                ELSEIF (IDBJT.EQ.119) THEN
29313                   NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29314                ENDIF
29315             ENDIF
29316          ELSE
29317 *   heavy fragments (here: fission products only)
29318             NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29319             NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29320             NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29321          ENDIF
29322       ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29323          IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29324       ENDIF
29325
29326       RETURN
29327 *------------------------------------------------------------------
29328 * output
29329     3 CONTINUE
29330
29331 **dble Po statistics.
29332 C     WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29333 C    &   '# evts. / # dble-Po. evts / s_in / s_popo :',
29334 C    & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29335
29336 *  emulsion treatment
29337       IF (NCOMPO.GT.0) THEN
29338          WRITE(LOUT,3000)
29339  3000    FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29340      &          22X,'----------------------------',/,/,19X,
29341      &          'mass    charge          fraction',/,39X,
29342      &          'input     treated',/)
29343          DO 30 I=1,NCOMPO
29344             WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29345      &                       EMUSAM(I)/DBLE(ICEVT)
29346  3013       FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29347    30    CONTINUE
29348       ENDIF
29349
29350 *  i.n.c. statistics: output
29351       WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29352  3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29353      &       22X,'---------------------------------',/,/,1X,
29354      &       'no. of events for normalization: (accepted final events,',
29355      &       ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29356      &       /,1X,'no. of rejected events due to intranuclear',
29357      &       ' cascade',15X,I6,/)
29358       ICEV  = MAX(ICEVT,1)
29359       ICEV1 = ICEV
29360       IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29361       WRITE(LOUT,3002)
29362      &     (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29363      &     ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29364      &     KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29365      &    (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29366      &     (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29367      &     (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29368      &     (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29369  3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29370      &       5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29371      &       ' proj./ target (mean per evt)',/,8X,'baryons:  pos. ',
29372      &       F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,/,8X,
29373      &       'mesons:   pos. ',F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,
29374      &       /,1X,'maximum no. of generations treated (maximum allowed:'
29375      &       ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29376      &       ' interactions in proj./ target (mean per evt1)',
29377      &       F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29378      &       ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29379      &       'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29380      &       '(ap, K-, pi- only)     ',F7.3,' /',F7.3,/)
29381       WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29382      &                 IREXCI(1)+IREXCI(2)+IREXCI(3)
29383  3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29384      &       'evaporation',/,22X,'-----------------------------',
29385      &       '------------',/,/,1X,'no. of events for normal.: ',
29386      &       '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29387      &       ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29388      &       ' rejected events     (',I4,',',I4,',',I4,')',22X,I6,/)
29389
29390       WRITE(LOUT,3004)
29391  3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29392       ICEV  = MAX(NRESEV(2),1)
29393       WRITE(LOUT,3005)
29394      &     (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29395      &     (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29396      &     (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29397      &     (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29398      &     (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29399      &     (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29400      &     (EXCDPM(I)/DBLE(ICEV),I=1,2),
29401      &     (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29402  3005    FORMAT(1X,'residual nuclei:  (mean values per evt)',12X,
29403      &       'proj. / target',/,/,8X,'total number of particles',15X,
29404      &       2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29405      &       'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29406      &       'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29407      &       /,8X,'excitation energy (bef. evap.-step)   ',2E11.3,/,
29408      &       8X,'excitation energy per nucleon         ',2E11.3,/,/)
29409
29410 * evaporation / fission / fragmentation statistics: output
29411       ICEV  = MAX(NRESEV(2),1)
29412       ICEV1 = MAX(NRESEV(4),1)
29413       NTEVA1 =
29414      &   NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29415       NTEVA2 =
29416      &   NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29417       IF (LEVPRT) THEN
29418
29419          IF (IEVFSS.EQ.1) CMSG(1) = 'requested    '
29420
29421          IF (LFRMBK)     CMSG(2) = 'requested    '
29422          IF (LDEEXG)     CMSG(3) = 'requested    '
29423          WRITE(LOUT,3006)
29424      &        CMSG,
29425      &        DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29426      &        (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29427      &        (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29428      &        (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29429      &        (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29430      &        (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29431      &        (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29432      &        (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29433      &        (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29434  3006    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,'Fission:',
29435      &       13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29436      &       'deexcitation:',2X,A13,/,/,
29437      &       1X,'evaporation/deexcitation:  (mean values per evt1)  ',
29438      &       'proj. / target',/,/,8X,'total number of evap. particles',
29439      &       9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29440      &       'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29441      &       '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29442      &       2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29443      &       'heavy fragments',25X,2F9.3,/)
29444
29445          IF (IEVFSS.EQ.1) THEN
29446
29447             WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29448      &                       NEVAFI(2,1),NEVAFI(2,2),
29449      &             DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29450      &             DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29451  3007       FORMAT(1X,'Fission:   total number of events',14X,2I9,/
29452      &             12X,'out of which fission occured',8X,2I9,/,
29453      &             50X,'(',F5.2,'%) (',F5.2,'%)',/)
29454          ENDIF
29455
29456 C        IF ((LFRMBK).OR.(IEVFSS.EQ.1)) THEN
29457
29458 C           WRITE(LOUT,3008)
29459 C3008       FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29460 C    &             '       proj.   / target',/)
29461 C           DO 31 I=1,210
29462 C              IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29463 C                 WRITE(LOUT,3009) I,
29464 C    &            (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29465 C3009             FORMAT(38X,I3,3X,2E12.3)
29466 C              ENDIF
29467 C  31       CONTINUE
29468 C           WRITE(LOUT,3010)
29469 C3010       FORMAT(1X,'heavy fragments - statistics:',7X,'mass  ',
29470 C    &             '       proj.   / target',/)
29471 C           DO 32 I=1,210
29472 C              IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29473 C                 WRITE(LOUT,3011) I,
29474 C    &            (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29475 C3011             FORMAT(38X,I3,3X,2E12.3)
29476 C              ENDIF
29477 C  32       CONTINUE
29478 C           WRITE(LOUT,*)
29479 C        ENDIF
29480       ELSE
29481          WRITE(LOUT,3012)
29482  3012    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,
29483      &       'Evaporation:         not requested',/)
29484       ENDIF
29485
29486       RETURN
29487 *------------------------------------------------------------------
29488 * filling of histogram with event-record
29489     4 CONTINUE
29490 *  emulsion treatment
29491       IF (NCOMPO.GT.0) THEN
29492          DO 40 I=1,NCOMPO
29493             IF (IT.EQ.IEMUMA(I)) THEN
29494                EMUSAM(I) = EMUSAM(I)+ONE
29495             ENDIF
29496    40    CONTINUE
29497       ENDIF
29498       NINCGE = NINCGE+MAXGEN
29499       MAXGEN = 0
29500 **dble Po statistics.
29501       IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29502
29503       RETURN
29504 *------------------------------------------------------------------
29505 * filling of histogram with event-record
29506     5 CONTINUE
29507       IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29508          IB = IIBAR(IDBAM(IDX))
29509          IC = IICH(IDBAM(IDX))
29510          J  = ISTHKK(IDX)-14
29511          IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29512             NINCST(J,1) = NINCST(J,1)+1
29513          ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29514             NINCST(J,2) = NINCST(J,2)+1
29515          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29516             NINCST(J,3) = NINCST(J,3)+1
29517          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29518             NINCST(J,4) = NINCST(J,4)+1
29519          ENDIF
29520       ELSEIF (ISTHKK(IDX).EQ.17) THEN
29521          NINCWO(1) = NINCWO(1)+1
29522       ELSEIF (ISTHKK(IDX).EQ.18) THEN
29523          NINCWO(2) = NINCWO(2)+1
29524       ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29525          IB = IDRES(IDX)
29526          IC = IDXRES(IDX)
29527          IF (IC.GT.0) THEN
29528             NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29529             NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29530          ENDIF
29531          NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29532       ENDIF
29533
29534       RETURN
29535       END
29536 *$ CREATE DT_NEWHGR.FOR
29537 *COPY DT_NEWHGR
29538 *
29539 *===newhgr=============================================================*
29540 *
29541       SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29542
29543 ************************************************************************
29544 *                                                                      *
29545 *     Histogram initialization.                                        *
29546 *                                                                      *
29547 *     input:  XLIM1/XLIM2  lower/upper edge of histogram-window        *
29548 *             XLIM3        bin size                                    *
29549 *             IBIN    > 0  number of bins in equidistant lin. binning  *
29550 *                     = -1 reset histograms                            *
29551 *                     < -1 |IBIN| number of bins in equidistant log.   *
29552 *                          binning or log. binning in user def. struc. *
29553 *             XLIMB(*)     user defined bin structure                  *
29554 *                                                                      *
29555 *     The bin structure is sensitive to                                *
29556 *             XLIM1, XLIM3, IBIN     if     XLIM3 > 0   (lin.)         *
29557 *             XLIM1, XLIM2, IBIN     if     XLIM3 = 0   (lin. & log.)  *
29558 *             XLIMB, IBIN            if     XLIM3 < 0                  *
29559 *                                                                      *
29560 *                                                                      *
29561 *     output: IREFN        histogram index                             *
29562 *                          (= -1 for inconsistent histogr. request)    *
29563 *                                                                      *
29564 * This subroutine is based on a original version by R. Engel.          *
29565 * This version dated 22.4.95 is written  by S. Roesler.                *
29566 ************************************************************************
29567
29568       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29569       SAVE
29570
29571       PARAMETER ( LINP = 10 ,
29572      &            LOUT = 6 ,
29573      &            LDAT = 9 )
29574
29575       LOGICAL LSTART
29576
29577       PARAMETER (ZERO   =  0.0D0,
29578      &           TINY   =  1.0D-10)
29579
29580       DIMENSION XLIMB(*)
29581
29582 * histograms
29583
29584       PARAMETER (NHIS=150, NDIM=250)
29585
29586       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29587      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29588
29589 * auxiliary common for histograms
29590       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29591
29592       DATA LSTART /.TRUE./
29593
29594 * reset histogram counter
29595       IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29596          IHISL  = 0
29597          IF (IBIN.EQ.-1) RETURN
29598          LSTART = .FALSE.
29599       ENDIF
29600
29601       IHIS  = IHISL+1
29602 * check for maximum number of allowed histograms
29603       IF (IHIS.GT.NHIS) THEN
29604          WRITE(LOUT,1003) IHIS,NHIS,IHIS
29605  1003    FORMAT(1X,'NEWHGR:   warning!  number of histograms (',
29606      &          I4,') exceeds array size (',I4,')',/,21X,
29607      &          'histogram',I3,' skipped!')
29608          GOTO 9999
29609       ENDIF
29610
29611       IREFN = IHIS
29612       IBINS(IHIS) = ABS(IBIN)
29613 * check requested number of bins
29614       IF (IBINS(IHIS).GE.NDIM) THEN
29615          WRITE(LOUT,1000) IBIN,NDIM,NDIM
29616  1000    FORMAT(1X,'NEWHGR:   warning!  number of bins (',
29617      &          I3,') exceeds array size (',I3,')',/,21X,
29618      &          'and will be reset to ',I3)
29619          IBINS(IHIS) = NDIM
29620       ENDIF
29621       IF (IBINS(IHIS).EQ.0) THEN
29622          WRITE(LOUT,1001) IBIN,IHIS
29623  1001    FORMAT(1X,'NEWHGR:   warning!  inconsistent number of',
29624      &          ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29625          GOTO 9999
29626       ENDIF
29627
29628 * initialize arrays
29629       DO 1 I=1,NDIM
29630          DO 2 K=1,3
29631             HIST(K,IHIS,I)   = ZERO
29632             HIST(K+3,IHIS,I) = ZERO
29633             TMPHIS(K,IHIS,I) = ZERO
29634     2    CONTINUE
29635          HIST(7,IHIS,I)   = ZERO
29636     1 CONTINUE
29637       DENTRY(1,IHIS)= ZERO
29638       DENTRY(2,IHIS)= ZERO
29639       OVERF(IHIS)   = ZERO
29640       UNDERF(IHIS)  = ZERO
29641       TMPUFL(IHIS)  = ZERO
29642       TMPOFL(IHIS)  = ZERO
29643
29644 * bin str. sensitive to lower edge, bin size, and numb. of bins
29645       IF (XLIM3.GT.ZERO) THEN
29646          DO 3 K=1,IBINS(IHIS)+1
29647             HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29648     3    CONTINUE
29649          ISWI(IHIS) = 1
29650 * bin str. sensitive to lower/upper edge and numb. of bins
29651       ELSEIF (XLIM3.EQ.ZERO) THEN
29652 *   linear binning
29653          IF (IBIN.GT.0) THEN
29654             XLOW = XLIM1
29655             XHI  = XLIM2
29656             IF (XLIM2.LE.XLIM1) THEN
29657                WRITE(LOUT,1002) XLIM1,XLIM2
29658  1002          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29659      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29660                GOTO 9999
29661             ENDIF
29662             ISWI(IHIS) = 1
29663          ELSEIF (IBIN.LT.-1) THEN
29664 *   logarithmic binning
29665             IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29666                WRITE(LOUT,1004) XLIM1,XLIM2
29667  1004          FORMAT(1X,'NEWHGR:   warning!  inconsistent log. ',
29668      &                'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29669                GOTO 9999
29670             ENDIF
29671             IF (XLIM2.LE.XLIM1) THEN
29672                WRITE(LOUT,1005) XLIM1,XLIM2
29673  1005          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29674      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29675                GOTO 9999
29676             ENDIF
29677             XLOW = LOG10(XLIM1)
29678             XHI  = LOG10(XLIM2)
29679             ISWI(IHIS) = 3
29680          ENDIF
29681          DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29682          DO 4 K=1,IBINS(IHIS)+1
29683             HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29684     4    CONTINUE
29685       ELSE
29686 * user defined bin structure
29687          DO 5 K=1,IBINS(IHIS)+1
29688             IF (IBIN.GT.0) THEN
29689                HIST(1,IHIS,K) = XLIMB(K)
29690                ISWI(IHIS) = 2
29691             ELSEIF (IBIN.LT.-1) THEN
29692                HIST(1,IHIS,K) = LOG10(XLIMB(K))
29693                ISWI(IHIS) = 4
29694             ENDIF
29695     5    CONTINUE
29696       ENDIF
29697
29698 * histogram accepted
29699       IHISL = IHIS
29700
29701       RETURN
29702
29703  9999 CONTINUE
29704       IREFN = -1
29705       RETURN
29706       END
29707
29708 *$ CREATE DT_FILHGR.FOR
29709 *COPY DT_FILHGR
29710 *
29711 *===filhgr=============================================================*
29712 *
29713       SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29714
29715 ************************************************************************
29716 *                                                                      *
29717 *     Scoring for histogram IHIS.                                      *
29718 *                                                                      *
29719 * This subroutine is based on a original version by R. Engel.          *
29720 * This version dated 23.4.95 is written  by S. Roesler.                *
29721 ************************************************************************
29722
29723       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29724       SAVE
29725
29726       PARAMETER ( LINP = 10 ,
29727      &            LOUT = 6 ,
29728      &            LDAT = 9 )
29729
29730       PARAMETER (ZERO = 0.0D0,
29731      &           ONE  = 1.0D0,
29732      &           TINY = 1.0D-10)
29733
29734 * histograms
29735
29736       PARAMETER (NHIS=150, NDIM=250)
29737
29738       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29739      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29740
29741 * auxiliary common for histograms
29742       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29743
29744       DATA NCEVT /1/
29745
29746       X = XI
29747       Y = YI
29748
29749 * dump content of temorary arrays into histograms
29750       IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29751          CALL DT_EVTHIS(IDUM)
29752          NCEVT = NEVT
29753       ENDIF
29754
29755 * check histogram index
29756       IF (IHIS.EQ.-1) RETURN
29757       IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29758 C        WRITE(LOUT,1000) IHIS,IHISL
29759  1000    FORMAT(1X,'FILHGR:   warning!  histogram index',I4,
29760      &          ' out of range (1..',I3,')')
29761          RETURN
29762       ENDIF
29763
29764       IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29765 * bin structure not explicitly given
29766          IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29767          DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29768          IF (X.LT.HIST(1,IHIS,1)) THEN
29769             I1 = 0
29770          ELSE
29771             I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29772          ENDIF
29773
29774       ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29775 * user defined bin structure
29776          IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29777          IF (X.LT.HIST(1,IHIS,1)) THEN
29778             I1 = 0
29779          ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29780             I1 = IBINS(IHIS)+1
29781          ELSE
29782 *   binary sort algorithm
29783             KMIN = 0
29784             KMAX = IBINS(IHIS)+1
29785     1       CONTINUE
29786             IF ((KMAX-KMIN).EQ.1) GOTO 2
29787             KK = (KMAX+KMIN)/2
29788             IF (X.LE.HIST(1,IHIS,KK)) THEN
29789                KMAX=KK
29790             ELSE
29791                KMIN=KK
29792             ENDIF
29793             GOTO 1
29794     2       CONTINUE
29795             I1 = KMIN
29796          ENDIF
29797
29798       ELSE
29799          WRITE(LOUT,1001)
29800  1001    FORMAT(1X,'FILHGR:   warning!  histogram not initialized')
29801          RETURN
29802       ENDIF
29803
29804 * scoring
29805       IF (I1.LE.0) THEN
29806          TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29807       ELSEIF (I1.LE.IBINS(IHIS)) THEN
29808          TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29809          IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29810             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29811          ELSE
29812             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29813          ENDIF
29814          TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29815       ELSE
29816          TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29817       ENDIF
29818
29819       RETURN
29820       END
29821
29822 *$ CREATE DT_EVTHIS.FOR
29823 *COPY DT_EVTHIS
29824 *
29825 *===evthis=============================================================*
29826 *
29827       SUBROUTINE DT_EVTHIS(NEVT)
29828
29829 ************************************************************************
29830 * Dump content of temorary histograms into /DTHIS1/. This subroutine   *
29831 * is called after each event and for the last event before any call    *
29832 * to OUTHGR.                                                           *
29833 *         NEVT   number of events dumped, this is only needed to       *
29834 *                get the normalization after the last event            *
29835 * This version dated 23.4.95 is written  by S. Roesler.                *
29836 ************************************************************************
29837
29838       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29839       SAVE
29840
29841       PARAMETER ( LINP = 10 ,
29842      &            LOUT = 6 ,
29843      &            LDAT = 9 )
29844
29845       LOGICAL LNOETY
29846
29847       PARAMETER (ZERO = 0.0D0,
29848      &           ONE  = 1.0D0,
29849      &           TINY = 1.0D-10)
29850
29851 * histograms
29852
29853       PARAMETER (NHIS=150, NDIM=250)
29854
29855       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29856      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29857
29858 * auxiliary common for histograms
29859       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29860
29861       DATA NCEVT /0/
29862
29863       NCEVT = NCEVT+1
29864       NEVT  = NCEVT
29865
29866       DO 1 I=1,IHISL
29867          LNOETY = .TRUE.
29868          DO 2 J=1,IBINS(I)
29869             IF (TMPHIS(1,I,J).GT.ZERO) THEN
29870                LNOETY = .FALSE.
29871                HIST(2,I,J)   = HIST(2,I,J)+ONE
29872                HIST(7,I,J)   = HIST(7,I,J)+TMPHIS(1,I,J)
29873                DENTRY(2,I)   = DENTRY(2,I)+TMPHIS(1,I,J)
29874                AVX           = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29875                HIST(3,I,J)   = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29876                HIST(4,I,J)   = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29877                HIST(5,I,J)   = HIST(5,I,J)+TMPHIS(3,I,J)
29878                HIST(6,I,J)   = HIST(6,I,J)+TMPHIS(3,I,J)**2
29879                TMPHIS(1,I,J) = ZERO
29880                TMPHIS(2,I,J) = ZERO
29881                TMPHIS(3,I,J) = ZERO
29882             ENDIF
29883     2    CONTINUE
29884          IF (LNOETY) THEN
29885             IF (TMPUFL(I).GT.ZERO) THEN
29886                UNDERF(I) = UNDERF(I)+ONE
29887                TMPUFL(I) = ZERO
29888             ELSEIF (TMPOFL(I).GT.ZERO) THEN
29889                OVERF(I)  = OVERF(I)+ONE
29890                TMPOFL(I) = ZERO
29891             ENDIF
29892          ELSE
29893             DENTRY(1,I) = DENTRY(1,I)+ONE
29894          ENDIF
29895     1 CONTINUE
29896
29897       RETURN
29898       END
29899
29900 *$ CREATE DT_OUTHGR.FOR
29901 *COPY DT_OUTHGR
29902 *
29903 *===outhgr=============================================================*
29904 *
29905       SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29906      &                  ILOGY,INORM,NMODE)
29907
29908 ************************************************************************
29909 *                                                                      *
29910 *     Plot histogram(s) to standard output unit                        *
29911 *                                                                      *
29912 *         I1..6         indices of histograms to be plotted            *
29913 *         CHEAD,IHEAD   header string,integer                          *
29914 *         NEVTS         number of events                               *
29915 *         FAC           scaling factor                                 *
29916 *         ILOGY   = 1   logarithmic y-axis                             *
29917 *         INORM         normalization                                  *
29918 *                 = 0   no further normalization (FAC is obsolete)     *
29919 *                 = 1   per event and bin width                        *
29920 *                 = 2   per entry and bin width                        *
29921 *                 = 3   per bin entry                                  *
29922 *                 = 4   per event and "bin width" x1^2...x2^2          *
29923 *                 = 5   per event and "log. bin width" ln x1..ln x2    *
29924 *                 = 6   per event                                      *
29925 *         MODE    = 0   no output but normalization applied            *
29926 *                 = 1   all valid histograms separately (small frame)  *
29927 *                       all valid histograms separately (small frame)  *
29928 *                 = -1  and tables as histograms                       *
29929 *                 = 2   all valid histograms (one plot, wide frame)    *
29930 *                       all valid histograms (one plot, wide frame)    *
29931 *                 = -2  and tables as histograms                       *
29932 *                                                                      *
29933 *                                                                      *
29934 *     Note: All histograms to be plotted with one call to this         *
29935 *           subroutine and |MODE|=2 must have the same bin structure!  *
29936 *           There is no test included ensuring this fact.              *
29937 *                                                                      *
29938 * This version dated 23.4.95 is written  by S. Roesler.                *
29939 ************************************************************************
29940
29941       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29942       SAVE
29943
29944       PARAMETER ( LINP = 10 ,
29945      &            LOUT = 6 ,
29946      &            LDAT = 9 )
29947
29948       CHARACTER*72 CHEAD
29949
29950       PARAMETER (ZERO   =  0.0D0,
29951      &           IZERO  =  0,
29952      &           ONE    =  1.0D0,
29953      &           TWO    =  2.0D0,
29954      &           OHALF  =  0.5D0,
29955      &           EPS    =  1.0D-5,
29956      &           TINY   =  1.0D-8,
29957      &           SMALL  =  -1.0D8,
29958      &           RLARGE =  1.0D8 )
29959
29960 * histograms
29961
29962       PARAMETER (NHIS=150, NDIM=250)
29963
29964       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29965      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29966
29967       PARAMETER (NDIM2 = 2*NDIM)
29968       DIMENSION XX(NDIM2),YY(NDIM2)
29969
29970       PARAMETER (NHISTO = 6)
29971       DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
29972      &          IDX(NHISTO)
29973
29974       CHARACTER*43 CNORM(0:8)
29975       DATA CNORM /'no further normalization                   ',
29976      &            'per event and bin width                    ',
29977      &            'per entry1 and bin width                   ',
29978      &            'per bin entry                              ',
29979      &            'per event and "bin width" x1^2...x2^2      ',
29980      &            'per event and "log. bin width" ln x1..ln x2',
29981      &            'per event                                  ',
29982      &            'per bin entry1                             ',
29983      &            'per entry2 and bin width                   '/
29984
29985       IDX1(1) = I1
29986       IDX1(2) = I2
29987       IDX1(3) = I3
29988       IDX1(4) = I4
29989       IDX1(5) = I5
29990       IDX1(6) = I6
29991
29992       MODE = NMODE
29993
29994 * initialization if "wide frame" is requested
29995       IF (ABS(MODE).EQ.2) THEN
29996          DO 1 I=1,NHISTO
29997             DO 2 J=1,NDIM
29998                XX1(J,I) = ZERO
29999                YY1(J,I) = ZERO
30000     2       CONTINUE
30001     1    CONTINUE
30002       ENDIF
30003
30004 * plot header
30005       WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30006
30007 * check histogram indices
30008       NHI = 0
30009       DO 3 I=1,NHISTO
30010          IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30011             IF (ISWI(IDX1(I)).NE.0) THEN
30012                IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30013                   WRITE(LOUT,1000)
30014      &                 IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30015  1000             FORMAT(/,1X,'OUTHGR:   warning!  no entries in',
30016      &                   ' histogram ',I3,/,21X,'underflows:',F10.0,
30017      &                   '   overflows:  ',F10.0)
30018                ELSE
30019                   NHI = NHI+1
30020                   IDX(NHI) = IDX1(I)
30021                ENDIF
30022             ENDIF
30023          ENDIF
30024     3 CONTINUE
30025       IF (NHI.EQ.0) THEN
30026          WRITE(LOUT,1001)
30027  1001    FORMAT(/,1X,'OUTHGR:   warning!  histogram indices not valid')
30028          RETURN
30029       ENDIF
30030
30031 * check normalization request
30032       IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30033      &     ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30034      &                        (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30035      &     (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30036          WRITE(LOUT,1002) NEVTS,INORM,FAC
30037  1002    FORMAT(/,1X,'OUTHGR:   warning!  normalization request not ',
30038      &          'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30039      &          'FAC = ',E11.4)
30040          RETURN
30041       ENDIF
30042
30043       WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30044
30045 * apply normalization
30046       DO 4 N=1,NHI
30047
30048          I = IDX(N)
30049
30050          IF (ISWI(I).EQ.1) THEN
30051             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30052  1003       FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30053      &             ' to',2X,E10.4,',',2X,I3,' bins')
30054          ELSEIF (ISWI(I).EQ.2) THEN
30055             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30056             WRITE(LOUT,1007)
30057  1007       FORMAT(1X,'user defined bin structure')
30058          ELSEIF (ISWI(I).EQ.3) THEN
30059             WRITE(LOUT,1004)
30060      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30061  1004       FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30062      &             ' to',2X,E10.4,',',2X,I3,' bins')
30063          ELSEIF (ISWI(I).EQ.4) THEN
30064             WRITE(LOUT,1004)
30065      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30066             WRITE(LOUT,1007)
30067          ELSE
30068             WRITE(LOUT,1008) ISWI(I)
30069  1008       FORMAT(/,1X,'warning!  inconsistent bin structure flag ',I4)
30070          ENDIF
30071          WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30072  1005    FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30073      &          ' overfl.:',F8.0)
30074          WRITE(LOUT,1009) CNORM(INORM)
30075  1009    FORMAT(1X,'normalization: ',A,/)
30076
30077          DO 5 K=1,IBINS(I)
30078             CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30079             YMEAN = FAC*YMEAN
30080             YERR  = FAC*YERR
30081             WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30082             WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30083  1006       FORMAT(1X,5E11.3)
30084 *    small frame
30085             II = 2*K
30086             XX(II-1) = HIST(1,I,K)
30087             XX(II)   = HIST(1,I,K+1)
30088             YY(II-1) = YMEAN
30089             YY(II)   = YMEAN
30090 *    wide frame
30091             XX1(K,N) = XMEAN
30092             IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30093      &         XX1(K,N) = LOG10(XMEAN)
30094             YY1(K,N) = YMEAN
30095     5    CONTINUE
30096
30097 * plot small frame
30098          IF (ABS(MODE).EQ.1) THEN
30099             IBIN2 = 2*IBINS(I)
30100             WRITE(LOUT,'(/,1X,A)') 'Preview:'
30101             IF(ILOGY.EQ.1) THEN
30102               CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30103             ELSE
30104               CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30105             ENDIF
30106          ENDIF
30107
30108     4 CONTINUE
30109
30110 * plot wide frame
30111       IF (ABS(MODE).EQ.2) THEN
30112          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30113          NSIZE = NDIM*NHISTO
30114          DXLOW = HIST(1,IDX(1),1)
30115          DDX   = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30116          YLOW  = RLARGE
30117          YHI   = SMALL
30118          DO 6 I=1,NHISTO
30119             DO 7 J=1,NDIM
30120                IF (YY1(J,I).LT.YLOW) THEN
30121                   IF (ILOGY.EQ.1) THEN
30122                      IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30123                   ELSE
30124                      YLOW = YY1(J,I)
30125                   ENDIF
30126                ENDIF
30127                IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30128     7       CONTINUE
30129     6    CONTINUE
30130          DY = (YHI-YLOW)/DBLE(NDIM)
30131          IF (DY.LE.ZERO) THEN
30132             WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30133      &         'OUTHGR:   warning! zero bin width for histograms ',
30134      &         IDX,': ',YLOW,YHI
30135             RETURN
30136          ENDIF
30137          IF (ILOGY.EQ.1) THEN
30138             YLOW = LOG10(YLOW)
30139             DY   = (LOG10(YHI)-YLOW)/100.0D0
30140             DO 8 I=1,NHISTO
30141                DO 9 J=1,NDIM
30142                   IF (YY1(J,I).LE.ZERO) THEN
30143                      YY1(J,I) = YLOW
30144                   ELSE
30145                      YY1(J,I) = LOG10(YY1(J,I))
30146                   ENDIF
30147     9          CONTINUE
30148     8       CONTINUE
30149          ENDIF
30150          CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30151       ENDIF
30152
30153       RETURN
30154       END
30155
30156 *$ CREATE DT_GETBIN.FOR
30157 *COPY DT_GETBIN
30158 *
30159 *===getbin=============================================================*
30160 *
30161       SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30162      &                  XMEAN,YMEAN,YERR)
30163
30164 ************************************************************************
30165 * This version dated 23.4.95 is written  by S. Roesler.                *
30166 ************************************************************************
30167
30168       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30169       SAVE
30170
30171       PARAMETER ( LINP = 10 ,
30172      &            LOUT = 6 ,
30173      &            LDAT = 9 )
30174
30175       PARAMETER (ZERO   = 0.0D0,
30176      &           ONE    = 1.0D0,
30177      &           TINY35 = 1.0D-35)
30178
30179 * histograms
30180
30181       PARAMETER (NHIS=150, NDIM=250)
30182
30183       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30184      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30185
30186       XLOW = HIST(1,IHIS,IBIN)
30187       XHI  = HIST(1,IHIS,IBIN+1)
30188       IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30189          XLOW = 10**XLOW
30190          XHI  = 10**XHI
30191       ENDIF
30192       IF (NORM.EQ.2) THEN
30193          DX   = XHI-XLOW
30194          NEVT = INT(DENTRY(1,IHIS))
30195       ELSEIF (NORM.EQ.3) THEN
30196          DX   = ONE
30197          NEVT = INT(HIST(2,IHIS,IBIN))
30198       ELSEIF (NORM.EQ.4) THEN
30199          DX   = XHI**2-XLOW**2
30200          NEVT = KEVT
30201       ELSEIF (NORM.EQ.5) THEN
30202          DX   = LOG(ABS(XHI))-LOG(ABS(XLOW))
30203          NEVT = KEVT
30204       ELSEIF (NORM.EQ.6) THEN
30205          DX   = ONE
30206          NEVT = KEVT
30207       ELSEIF (NORM.EQ.7) THEN
30208          DX   = ONE
30209          NEVT = INT(HIST(7,IHIS,IBIN))
30210       ELSEIF (NORM.EQ.8) THEN
30211          DX   = XHI-XLOW
30212          NEVT = INT(DENTRY(2,IHIS))
30213       ELSE
30214          DX   = ABS(XHI-XLOW)
30215          NEVT = KEVT
30216       ENDIF
30217       IF (ABS(DX).LT.TINY35) DX = ONE
30218       NEVT   = MAX(NEVT,1)
30219       YMEAN  = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30220       YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30221       YERR   = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30222       YSUM   = HIST(5,IHIS,IBIN)
30223       IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30224 C     XMEAN  = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30225       XMEAN  = HIST(3,IHIS,IBIN)/YSUM
30226       IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30227
30228       RETURN
30229       END
30230
30231 *$ CREATE DT_JOIHIS.FOR
30232 *COPY DT_JOIHIS
30233 *
30234 *===joihis=============================================================*
30235 *
30236       SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30237
30238 ************************************************************************
30239 *                                                                      *
30240 *     Operation on histograms.                                         *
30241 *                                                                      *
30242 *     input:  IH1,IH2      histogram indices to be joined              *
30243 *             COPER        character defining the requested operation, *
30244 *                          i.e. '+', '-', '*', '/'                     *
30245 *             FAC1,FAC2    factors for joining, i.e.                   *
30246 *                          FAC1*histo1 COPER FAC2*histo2               *
30247 *                                                                      *
30248 * This version dated 23.4.95 is written  by S. Roesler.                *
30249 ************************************************************************
30250
30251       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30252       SAVE
30253
30254       PARAMETER ( LINP = 10 ,
30255      &            LOUT = 6 ,
30256      &            LDAT = 9 )
30257
30258       CHARACTER COPER*1
30259
30260       PARAMETER (ZERO   =  0.0D0,
30261      &           ONE    =  1.0D0,
30262      &           OHALF  =  0.5D0,
30263      &           TINY8  =  1.0D-8,
30264      &           SMALL  =  -1.0D8,
30265      &           RLARGE =  1.0D8 )
30266
30267 * histograms
30268
30269       PARAMETER (NHIS=150, NDIM=250)
30270
30271       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30272      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30273
30274       PARAMETER (NDIM2 = 2*NDIM)
30275       DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30276
30277       CHARACTER*43 CNORM(0:6)
30278       DATA CNORM /'no further normalization                   ',
30279      &            'per event and bin width                    ',
30280      &            'per entry and bin width                    ',
30281      &            'per bin entry                              ',
30282      &            'per event and "bin width" x1^2...x2^2      ',
30283      &            'per event and "log. bin width" ln x1..ln x2',
30284      &            'per event                                  '/
30285
30286 * check histogram indices
30287       IF ((IH1.LT.    1).OR.(IH2.LT.    1).OR.
30288      &    (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30289          WRITE(LOUT,1000) IH1,IH2,IHISL
30290  1000    FORMAT(1X,'JOIHIS:   warning!  inconsistent histogram ',
30291      &          'indices (',I3,',',I3,'),',/,21X,'valid range:  1,',I3)
30292          GOTO 9999
30293       ENDIF
30294
30295 * check bin structure of histograms to be joined
30296       IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30297          WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30298  1001    FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30299      &          ' and ',I3,' failed',/,21X,
30300      &          'due to different numbers of bins (',I3,',',I3,')')
30301          GOTO 9999
30302       ENDIF
30303       DO 1 K=1,IBINS(IH1)+1
30304          IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30305             WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30306  1002       FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30307      &             ' and ',I3,' failed at bin edge ',I3,/,21X,
30308      &             'X1,X2 = ',2E11.4)
30309             GOTO 9999
30310          ENDIF
30311     1 CONTINUE
30312
30313       WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30314  1003 FORMAT(1X,'JOIHIS:   joining histograms ',I3,',',I3,' with ',
30315      &       'operation ',A,/,11X,'and factors ',2E11.4)
30316       WRITE(LOUT,1004) CNORM(NORM)
30317  1004 FORMAT(1X,'normalization: ',A,/)
30318
30319       DO 2 K=1,IBINS(IH1)
30320          CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30321          CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30322          XLOW  = XLOW1
30323          XHI   = XHI1
30324          XMEAN = OHALF*(XMEAN1+XMEAN2)
30325          IF (COPER.EQ.'+') THEN
30326             YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30327          ELSEIF (COPER.EQ.'*') THEN
30328             YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30329          ELSEIF (COPER.EQ.'/') THEN
30330             IF (YMEAN2.EQ.ZERO) THEN
30331                YMEAN = ZERO
30332             ELSE
30333                IF (FAC2.EQ.ZERO) FAC2 = ONE
30334                YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30335             ENDIF
30336          ELSE
30337             GOTO 9998
30338          ENDIF
30339          WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30340          WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30341  1006    FORMAT(1X,5E11.3)
30342 *    small frame
30343          II = 2*K
30344          XX(II-1) = HIST(1,IH1,K)
30345          XX(II)   = HIST(1,IH1,K+1)
30346          YY(II-1) = YMEAN
30347          YY(II)   = YMEAN
30348 *    wide frame
30349          XX1(K) = XMEAN
30350          IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30351          YY1(K) = YMEAN
30352     2 CONTINUE
30353
30354 * plot small frame
30355       IF (ABS(MODE).EQ.1) THEN
30356          IBIN2 = 2*IBINS(IH1)
30357          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30358          IF(ILOGY.EQ.1) THEN
30359            CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30360          ELSE
30361            CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30362          ENDIF
30363       ENDIF
30364
30365 * plot wide frame
30366       IF (ABS(MODE).EQ.2) THEN
30367          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30368          NSIZE = NDIM
30369          DXLOW = HIST(1,IH1,1)
30370          DDX   = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30371          YLOW  = RLARGE
30372          YHI   = SMALL
30373          DO 3 I=1,NDIM
30374             IF (YY1(I).LT.YLOW) THEN
30375                IF (ILOGY.EQ.1) THEN
30376                   IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30377                ELSE
30378                   YLOW = YY1(I)
30379                ENDIF
30380             ENDIF
30381             IF (YY1(I).GT.YHI) YHI = YY1(I)
30382     3    CONTINUE
30383          DY = (YHI-YLOW)/DBLE(NDIM)
30384          IF (DY.LE.ZERO) THEN
30385             WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30386      &         'JOIHIS:   warning! zero bin width for histograms ',
30387      &         IH1,IH2,': ',YLOW,YHI
30388             RETURN
30389          ENDIF
30390          IF (ILOGY.EQ.1) THEN
30391             YLOW = LOG10(YLOW)
30392             DY   = (LOG10(YHI)-YLOW)/100.0D0
30393             DO 4 I=1,NDIM
30394                IF (YY1(I).LE.ZERO) THEN
30395                   YY1(I) = YLOW
30396                ELSE
30397                   YY1(I) = LOG10(YY1(I))
30398                ENDIF
30399     4       CONTINUE
30400          ENDIF
30401          CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30402       ENDIF
30403
30404       RETURN
30405
30406  9998 CONTINUE
30407       WRITE(LOUT,1005) COPER
30408  1005 FORMAT(1X,'JOIHIS:   unknown operation ',A)
30409
30410  9999 CONTINUE
30411       RETURN
30412       END
30413
30414 *$ CREATE DT_XGRAPH.FOR
30415 *COPY DT_XGRAPH
30416 *
30417 *===qgraph=============================================================*
30418 *
30419       SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30420 C***********************************************************************
30421 C
30422 C     calculate quasi graphic picture with 25 lines and 79 columns
30423 C     ranges will be chosen automatically
30424 C
30425 C     input     N          dimension of input fields
30426 C               IARG       number of curves (fields) to plot
30427 C               X          field of X
30428 C               Y1         field of Y1
30429 C               Y2         field of Y2
30430 C
30431 C This subroutine is written by R. Engel.
30432 C***********************************************************************
30433       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30434       SAVE
30435
30436       PARAMETER ( LINP = 10 ,
30437      &            LOUT = 6 ,
30438      &            LDAT = 9 )
30439
30440 C
30441       DIMENSION X(N),Y1(N),Y2(N)
30442       PARAMETER (EPS=1.D-30)
30443       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30444       CHARACTER SYMB(5)
30445       CHARACTER COL(0:149,0:49)
30446 C
30447       DATA SYMB /'0','e','z','#','x'/
30448 C
30449       ISPALT=IBREIT-10
30450 C
30451 C***  automatic range fitting
30452 C
30453       XMAX=X(1)
30454       XMIN=X(1)
30455       DO 600 I=1,N
30456          XMAX=MAX(X(I),XMAX)
30457          XMIN=MIN(X(I),XMIN)
30458  600  CONTINUE
30459       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30460 C
30461       ITEST=0
30462       DO 1100 K=0,IZEIL-1
30463          ITEST=ITEST+1
30464          IF (ITEST.EQ.IYRAST) THEN
30465             DO 1010 L=1,ISPALT-1
30466                COL(L,K)='-'
30467 1010        CONTINUE
30468             COL(ISPALT,K)='+'
30469             ITEST=0
30470             DO 1020 L=0,ISPALT-1,IXRAST
30471                COL(L,K)='+'
30472 1020        CONTINUE
30473          ELSE
30474             DO 1030 L=1,ISPALT-1
30475                COL(L,K)=' '
30476 1030        CONTINUE
30477             DO 1040 L=0,ISPALT-1,IXRAST
30478                COL(L,K)='|'
30479 1040        CONTINUE
30480             COL(ISPALT,K)='|'
30481          ENDIF
30482 1100  CONTINUE
30483 C
30484 C***  plot curve Y1
30485 C
30486       YMAX=Y1(1)
30487       YMIN=Y1(1)
30488       DO 500 I=1,N
30489          YMAX=MAX(Y1(I),YMAX)
30490          YMIN=MIN(Y1(I),YMIN)
30491 500   CONTINUE
30492       IF(IARG.GT.1) THEN
30493         DO 550 I=1,N
30494            YMAX=MAX(Y2(I),YMAX)
30495            YMIN=MIN(Y2(I),YMIN)
30496 550     CONTINUE
30497       ENDIF
30498       YMAX=(YMAX-YMIN)/40.0D0+YMAX
30499       YMIN=YMIN-(YMAX-YMIN)/40.0D0
30500       YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30501       IF(YZOOM.LT.EPS) THEN
30502         WRITE(LOUT,'(1X,A)')
30503      &    'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30504         RETURN
30505       ENDIF
30506 C
30507 C***  plot curve Y1
30508 C
30509       ILAST=-1
30510       LLAST=-1
30511       DO 1200 K=1,N
30512          L=NINT((X(K)-XMIN)/XZOOM)
30513          I=NINT((YMAX-Y1(K))/YZOOM)
30514          IF(ILAST.GE.0) THEN
30515            LD = L-LLAST
30516            ID = I-ILAST
30517            DO 55 II=0,LD,SIGN(1,LD)
30518              DO 66 KK=0,ID,SIGN(1,ID)
30519                COL(II+LLAST,KK+ILAST)=SYMB(1)
30520  66          CONTINUE
30521  55        CONTINUE
30522          ELSE
30523            COL(L,I)=SYMB(1)
30524          ENDIF
30525          ILAST = I
30526          LLAST = L
30527 1200  CONTINUE
30528 C
30529       IF(IARG.GT.1) THEN
30530 C
30531 C***  plot curve Y2
30532 C
30533         DO 1250 K=1,N
30534            L=NINT((X(K)-XMIN)/XZOOM)
30535            I=NINT((YMAX-Y2(K))/YZOOM)
30536            COL(L,I)=SYMB(2)
30537 1250    CONTINUE
30538       ENDIF
30539 C
30540 C***  write it
30541 C
30542       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30543 C
30544 C***  write range of X
30545 C
30546       XZOOM = (XMAX-XMIN)/DBLE(7)
30547       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30548 C
30549       DO 1300 K=0,IZEIL-1
30550          YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30551          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30552  110     FORMAT(1X,1PE9.2,70A1)
30553 1300  CONTINUE
30554 C
30555 C***  write range of X
30556 C
30557       XZOOM = (XMAX-XMIN)/DBLE(7)
30558       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30559       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30560  120  FORMAT(6X,7(1PE10.3))
30561       END
30562
30563 *$ CREATE DT_XGLOGY.FOR
30564 *COPY DT_XGLOGY
30565 *
30566 *===qglogy=============================================================*
30567 *
30568       SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30569 C***********************************************************************
30570 C
30571 C     calculate quasi graphic picture with 25 lines and 79 columns
30572 C     logarithmic y axis
30573 C     ranges will be chosen automatically
30574 C
30575 C     input     N          dimension of input fields
30576 C               IARG       number of curves (fields) to plot
30577 C               X          field of X
30578 C               Y1         field of Y1
30579 C               Y2         field of Y2
30580 C
30581 C This subroutine is written by R. Engel.
30582 C***********************************************************************
30583 C
30584       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30585       SAVE
30586
30587       PARAMETER ( LINP = 10 ,
30588      &            LOUT = 6 ,
30589      &            LDAT = 9 )
30590
30591       DIMENSION X(N),Y1(N),Y2(N)
30592       PARAMETER (EPS=1.D-30)
30593       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30594       CHARACTER SYMB(5)
30595       CHARACTER COL(0:149,0:49)
30596       PARAMETER (DEPS = 1.D-10)
30597 C
30598       DATA SYMB /'0','e','z','#','x'/
30599 C
30600       ISPALT=IBREIT-10
30601 C
30602 C***  automatic range fitting
30603 C
30604       XMAX=X(1)
30605       XMIN=X(1)
30606       DO 600 I=1,N
30607          XMAX=MAX(X(I),XMAX)
30608          XMIN=MIN(X(I),XMIN)
30609  600  CONTINUE
30610       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30611 C
30612       ITEST=0
30613       DO 1100 K=0,IZEIL-1
30614          ITEST=ITEST+1
30615          IF (ITEST.EQ.IYRAST) THEN
30616             DO 1010 L=1,ISPALT-1
30617                COL(L,K)='-'
30618 1010        CONTINUE
30619             COL(ISPALT,K)='+'
30620             ITEST=0
30621             DO 1020 L=0,ISPALT-1,IXRAST
30622                COL(L,K)='+'
30623 1020        CONTINUE
30624          ELSE
30625             DO 1030 L=1,ISPALT-1
30626                COL(L,K)=' '
30627 1030        CONTINUE
30628             DO 1040 L=0,ISPALT-1,IXRAST
30629                COL(L,K)='|'
30630 1040        CONTINUE
30631             COL(ISPALT,K)='|'
30632          ENDIF
30633 1100  CONTINUE
30634 C
30635 C***  plot curve Y1
30636 C
30637       YMAX=Y1(1)
30638       YMIN=MAX(Y1(1),EPS)
30639       DO 500 I=1,N
30640          YMAX =MAX(Y1(I),YMAX)
30641          IF(Y1(I).GT.EPS) THEN
30642            IF(YMIN.EQ.EPS) THEN
30643              YMIN = Y1(I)/10.D0
30644            ELSE
30645              YMIN = MIN(Y1(I),YMIN)
30646            ENDIF
30647          ENDIF
30648 500   CONTINUE
30649       IF(IARG.GT.1) THEN
30650         DO 550 I=1,N
30651            YMAX=MAX(Y2(I),YMAX)
30652            IF(Y2(I).GT.EPS) THEN
30653              IF(YMIN.EQ.EPS) THEN
30654                YMIN = Y2(I)
30655              ELSE
30656                YMIN = MIN(Y2(I),YMIN)
30657              ENDIF
30658            ENDIF
30659 550     CONTINUE
30660       ENDIF
30661 C
30662       DO 560 I=1,N
30663         Y1(I) = MAX(Y1(I),YMIN)
30664  560  CONTINUE
30665       IF(IARG.GT.1) THEN
30666         DO 570 I=1,N
30667           Y2(I) = MAX(Y2(I),YMIN)
30668  570    CONTINUE
30669       ENDIF
30670 C
30671       IF(YMAX.LE.YMIN) THEN
30672         WRITE(LOUT,'(/1X,A,2E12.3,/)')
30673      &     'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30674         WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30675         RETURN
30676       ENDIF
30677 C
30678       YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30679       YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30680       YZOOM=(YMA-YMI)/DBLE(IZEIL)
30681       IF(YZOOM.LT.EPS) THEN
30682         WRITE(LOUT,'(1X,A)')
30683      &    'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30684         RETURN
30685       ENDIF
30686 C
30687 C***  plot curve Y1
30688 C
30689       ILAST=-1
30690       LLAST=-1
30691       DO 1200 K=1,N
30692          L=NINT((X(K)-XMIN)/XZOOM)
30693          I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30694          IF(ILAST.GE.0) THEN
30695            LD = L-LLAST
30696            ID = I-ILAST
30697            DO 55 II=0,LD,SIGN(1,LD)
30698              DO 66 KK=0,ID,SIGN(1,ID)
30699                COL(II+LLAST,KK+ILAST)=SYMB(1)
30700  66          CONTINUE
30701  55        CONTINUE
30702          ELSE
30703            COL(L,I)=SYMB(1)
30704          ENDIF
30705          ILAST = I
30706          LLAST = L
30707 1200  CONTINUE
30708 C
30709       IF(IARG.GT.1) THEN
30710 C
30711 C***  plot curve Y2
30712 C
30713         DO 1250 K=1,N
30714            L=NINT((X(K)-XMIN)/XZOOM)
30715            I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30716            COL(L,I)=SYMB(2)
30717 1250    CONTINUE
30718       ENDIF
30719 C
30720 C***  write it
30721 C
30722       WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30723       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30724 C
30725 C***  write range of X
30726 C
30727       XZOOM1 = (XMAX-XMIN)/DBLE(7)
30728       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30729 C
30730       DO 1300 K=0,IZEIL-1
30731          YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30732          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30733  110     FORMAT(1X,1PE9.2,70A1)
30734 1300  CONTINUE
30735 C
30736 C***  write range of X
30737 C
30738       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30739       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30740  120  FORMAT(6X,7(1PE10.3))
30741 C
30742       END
30743
30744 *$ CREATE DT_SRPLOT.FOR
30745 *COPY DT_SRPLOT
30746 *
30747 *===plot===============================================================*
30748 *
30749       SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30750
30751       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30752       SAVE
30753
30754       PARAMETER ( LINP = 10 ,
30755      &            LOUT = 6 ,
30756      &            LDAT = 9 )
30757
30758 *
30759 *     initial version
30760 *     J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30761 *     This is a subroutine of fluka to plot Y across the page
30762 *     as a function of X down the page. Up to 37 curves can be
30763 *     plotted in the same picture with different plotting characters.
30764 *     Output of first 10 overprinted characters addad by FB 88
30765 *  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30766 *
30767 *     Input Variables:
30768 *        X   = array containing the values of X
30769 *        Y   = array containing the values of Y
30770 *        N   = number of values in X and in Y
30771 *              can exceed the fixed number of lines
30772 *        M   = number of different curves X,Y are containing
30773 *        MM  = number of points in each curve i.e. N=M*MM
30774 *        XO  = smallest value of X to be plotted
30775 *        DX  = increment of X between subsequent lines
30776 *        YO  = smallest value of Y to be plotted
30777 *        DY  = increment of Y between subsequent character spaces
30778 *
30779 *        other variables used inside:
30780 *        XX  = numbers along the X-coordinate axis
30781 *        YY  = numbers along the Y-coordinate axis
30782 *        LL  = ten lines temporary storage for the plot
30783 *        L   = character set used to plot different curves
30784 *        LOV = memorizes overprinted symbols
30785 *              the first 10 overprinted symbols are printed on
30786 *              the end of the line to avoid ambiguities
30787 *              (added by FB as considered quite helpful)
30788 *
30789 *********************************************************************
30790 *
30791       DIMENSION XX(61),YY(61),LL(101,10)
30792       DIMENSION X(N),Y(N),L(40),LOV(40,10)
30793       INTEGER*4 LL, L, LOV
30794       DATA  L/
30795      11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30796      21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30797      31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30798      41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H  /
30799 *
30800 *
30801       MN=51
30802       DO 10 I=1,MN
30803         AI=I-1
30804    10 XX(I)=XO+AI*DX
30805       DO 20 I=1,11
30806         AI=I-1
30807    20 YY(I)=YO+10.0D0*AI*DY
30808       WRITE(LOUT, 500) (YY(I),I=1,11)
30809       MMN=MN-1
30810 *
30811 *
30812       DO 90 JJ=1,MMN,10
30813         JJJ=JJ-1
30814         DO 30 I=1,101
30815           DO 30 J=1,10
30816    30   LL(I,J)=L(40)
30817         DO 40 I=1,101
30818    40   LL(I,1)=L(39)
30819         DO 50 I=1,101,10
30820           DO 50 J=1,10
30821    50   LL(I,J)=L(38)
30822         DO 60 I=1,40
30823           DO 60 J=1,10
30824    60   LOV(I,J)=L(40)
30825 *
30826 *
30827         DO 70 I=1,M
30828           DO 70 J=1,MM
30829             II=J+(I-1)*MM
30830             AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30831             AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30832             AIX=AIX-DBLE(JJJ)
30833 *           changed Sept.88 by FB to avoid INTEGER OVERFLOW
30834             IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30835      +      . AIY .LT. 102.D0) THEN
30836               IX=INT(AIX)
30837               IY=INT(AIY)
30838               IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30839      +        THEN
30840                 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30841      +          =LL(IY,IX)
30842                 LL(IY,IX)=L(I)
30843               ENDIF
30844             ENDIF
30845    70   CONTINUE
30846 *
30847 *
30848         DO 80 I=1,10
30849           II=I+JJJ
30850           III=II+1
30851           WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30852      &                    (LOV(J,I),J=1,10)
30853    80   CONTINUE
30854    90 CONTINUE
30855 *
30856 *
30857       WRITE(LOUT, 520)
30858       WRITE(LOUT, 500) (YY(I),I=1,11)
30859       RETURN
30860 *
30861   500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30862   510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30863   520 FORMAT(20X,10('1---------'),'1')
30864       END
30865 *$ CREATE DT_DEFSET.FOR
30866 *COPY DT_DEFSET
30867 *
30868 *===defset=============================================================*
30869 *
30870       BLOCK DATA DT_DEFSET
30871
30872       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30873       SAVE
30874
30875 * flags for input different options
30876       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30877       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30878      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30879
30880       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30881
30882 * emulsion treatment
30883       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30884      &                NCOMPO,IEMUL
30885
30886 * / DTFLG1 /
30887       DATA IFRAG  / 2, 1 /
30888       DATA IRESCO / 1 /
30889       DATA IMSHL  / 1 /
30890       DATA IRESRJ / 0 /
30891       DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30892       DATA LEMCCK / .FALSE. /
30893       DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30894      &              .TRUE.,.TRUE.,.TRUE./
30895       DATA LSEADI / .TRUE. /
30896       DATA LEVAPO / .TRUE. /
30897       DATA IFRAME / 1 /
30898       DATA ITRSPT / 0 /
30899
30900 * / DTCOMP /
30901       DATA EMUFRA / NCOMPX*0.0D0 /
30902       DATA IEMUMA / NCOMPX*1 /
30903       DATA IEMUCH / NCOMPX*1 /
30904       DATA NCOMPO / 0 /
30905       DATA IEMUL  / 0 /
30906
30907       END
30908
30909 *$ CREATE DT_HADPRP.FOR
30910 *COPY DT_HADPRP
30911 *
30912 *===hadprp=============================================================*
30913 *
30914       BLOCK DATA DT_HADPRP
30915
30916       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30917       SAVE
30918
30919 * auxiliary common for reggeon exchange (DTUNUC 1.x)
30920       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30921      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30922      &                IQTCHR(-6:6),MQUARK(3,39)
30923
30924 * hadron index conversion (BAMJET <--> PDG)
30925       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30926      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30927      &                IAMCIN(210)
30928
30929 * names of hadrons used in input-cards
30930       CHARACTER*8 BTYPE
30931       COMMON /DTPAIN/ BTYPE(30)
30932
30933 * / DTQUAR /
30934 *----------------------------------------------------------------------*
30935 *                                                                      *
30936 *     Quark content of particles:                                      *
30937 *          index   quark   el. charge  bar. charge  isospin  isospin3  *
30938 *              1 = u          2/3          1/3        1/2       1/2    *
30939 *             -1 = ubar      -2/3         -1/3        1/2      -1/2    *
30940 *              2 = d         -1/3          1/3        1/2      -1/2    *
30941 *             -2 = dbar       1/3         -1/3        1/2       1/2    *
30942 *              3 = s         -1/3          1/3         0         0     *
30943 *             -3 = sbar       1/3         -1/3         0         0     *
30944 *              4 = c          2/3          1/3         0         0     *
30945 *             -4 = cbar      -2/3         -1/3         0         0     *
30946 *              5 = b         -1/3          1/3         0         0     *
30947 *             -5 = bbar       1/3         -1/3         0         0     *
30948 *              6 = t          2/3          1/3         0         0     *
30949 *             -6 = tbar      -2/3         -1/3         0         0     *
30950 *                                                                      *
30951 *         Mquark = particle quark composition (Paprop numbering)       *
30952 *         Iqechr = electric charge ( in 1/3 unit )                     *
30953 *         Iqbchr = baryonic charge ( in 1/3 unit )                     *
30954 *         Iqichr = isospin ( in 1/2 unit ), z component                *
30955 *         Iqschr = strangeness                                         *
30956 *         Iqcchr = charm                                               *
30957 *         Iquchr = beauty                                              *
30958 *         Iqtchr = ......                                              *
30959 *                                                                      *
30960 *----------------------------------------------------------------------*
30961       DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
30962       DATA IQBCHR / 6*-1, 0, 6*1 /
30963       DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
30964       DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
30965       DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
30966       DATA IQUCHR / 0, 1, 9*0, -1, 0 /
30967       DATA IQTCHR / -1, 11*0, 1 /
30968       DATA MQUARK /
30969      &   2, 1, 1,   -2,-1,-1,    0, 0, 0,    0, 0, 0,    0, 0, 0,
30970      &   0, 0, 0,    0, 0, 0,    2, 2, 1,   -2,-2,-1,    0, 0, 0,
30971      &   0, 0, 0,    0, 0, 0,    1,-2, 0,    2,-1, 0,    1,-3, 0,
30972      &   3,-1, 0,    1, 2, 3,   -1,-2,-3,    0, 0, 0,    2, 2, 3,
30973      &   1, 1, 3,    1, 2, 3,    1,-1, 0,    2,-3, 0,    3,-2, 0,
30974      &   2,-2, 0,    3,-3, 0,    0, 0, 0,    0, 0, 0,    0, 0, 0,
30975      &  -1,-1,-3,   -1,-2,-3,   -2,-2,-3,    1, 3, 3,   -1,-3,-3,
30976      &   2, 3, 3,   -2,-3,-3,    3, 3, 3,   -3,-3,-3 /
30977
30978 * / DTHAIC /
30979 * (renamed) (HAdron InDex COnversion)
30980 * translation table version filled up by r.e. 25.01.94                 *
30981       DATA IAMCIN /
30982      &2212,-2212,11,-11,12,              -12,22,2112,-2112,-13,
30983      &13,130,211,-211,321,               -321,3122,-3122,310,3112,
30984      &3222,3212,111,311,-311,            0,0,0,0,0,
30985      &221,213,113,-213,223,              323,313,-323,-313,10323,
30986      &10313,-10323,-10313,30323,30313,   -30323,-30313,3224,3214,3114,
30987      &3216,3218,2224,2214,2114,          1114,12224,12214,12114,11114,
30988      &99999,99999,22212,22112,32124,     31214,-2224,-2214,-2114,-1114,
30989      &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
30990      &5*99999,                           5*99999,
30991      &4*99999,331,                       333,3322,3312,-3222,-3212,
30992      &-3112,-3322,-3312,3224,3214,       3114,3324,3314,3334,-3224,
30993      &-3214,-3114,-3324,-3314,-3334,     421,411,-411,-421,431,
30994      &-431,441,423,413,-413,             -423,433,-433,20443,443,
30995      &-15,15,16,-16,14,                  -14,4122,4232,4132,4222,
30996      &4212,4112,3*99999,                 3*99999,-4122,-4232,
30997      &-4132,-4222,-4212,-4112,99999,     5*99999,
30998      &5*99999,                           5*99999,
30999      &10*99999,
31000      &5*99999 , 20211,20111,-20211,99999,20321,
31001      &-20321,20311,-20311,7*99999 ,
31002      &7*99999,12212,12112,99999/
31003
31004 * / DTHAIC /
31005 * (HAdron InDex COnversion)
31006       DATA (IPDG2(1,K),K=1,7)
31007      &   /   -11,   -12,   -13,   -15,   -16,   -14,     0/
31008       DATA (IBAM2(1,K),K=1,7)
31009      &   /     4,     6,    10,   131,   134,   136,     0/
31010       DATA (IPDG2(2,K),K=1,7)
31011      &   /    11,    12,    22,    13,    15,    16,    14/
31012       DATA (IBAM2(2,K),K=1,7)
31013      &   /     3,     5,     7,    11,   132,   133,   135/
31014       DATA (IPDG3(1,K),K=1,22)
31015      &   /  -211,  -321,  -311,  -213,  -323,  -313,  -411,  -421,
31016      &      -431,  -413,  -423,  -433,     0,     0,     0,     0,
31017      &         0,     0,     0,     0,     0,     0/
31018       DATA (IBAM3(1,K),K=1,22)
31019      &   /    14,    16,    25,    34,    38,    39,   118,   119,
31020      &       121,   125,   126,   128,     0,     0,     0,     0,
31021      &         0,     0,     0,     0,     0,     0/
31022       DATA (IPDG3(2,K),K=1,22)
31023      &   /   130,   211,   321,   310,   111,   311,   221,   213,
31024      &       113,   223,   323,   313,   331,   333,   421,   411,
31025      &       431,   441,   423,   413,   433,   443/
31026       DATA (IBAM3(2,K),K=1,22)
31027      &   /    12,    13,    15,    19,    23,    24,    31,    32,
31028      &        33,    35,    36,    37,    95,    96,   116,   117,
31029      &       120,   122,   123,   124,   127,   130/
31030       DATA (IPDG4(1,K),K=1,29)
31031      &   / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31032      &     -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31033      &     -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31034      &     -4212, -4112,     0,     0,     0/
31035       DATA (IBAM4(1,K),K=1,29)
31036      &   /     2,     9,    18,    67,    68,    69,    70,    75,
31037      &        76,    99,   100,   101,   102,   103,   110,   111,
31038      &       112,   113,   114,   115,   149,   150,   151,   152,
31039      &       153,   154,     0,     0,     0/
31040       DATA (IPDG4(2,K),K=1,29)
31041      &   /  2212,  2112,  3122,  3112,  3222,  3212,  3224,  3214,
31042      &      3114,  3216,  3218,  2224,  2214,  2114,  1114,  3322,
31043      &      3312,  3224,  3214,  3114,  3324,  3314,  3334,  4122,
31044      &      4232,  4132,  4222,  4212,  4112/
31045       DATA (IBAM4(2,K),K=1,29)
31046      &   /     1,     8,    17,    20,    21,    22,    48,    49,
31047      &        50,    51,    52,    53,    54,    55,    56,    97,
31048      &        98,   104,   105,   106,   107,   108,   109,   137,
31049      &       138,   139,   140,   141,   142/
31050       DATA (IPDG5(1,K),K=1,19)
31051      &   /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31052      &    -20211,-20321,-20311,     0,     0,     0,     0,     0,
31053      &         0,     0,     0/
31054       DATA (IBAM5(1,K),K=1,19)
31055      &   /    42,    43,    46,    47,    71,    72,    73,    74,
31056      &       188,   191,   193,     0,     0,     0,     0,     0,
31057      &         0,     0,     0/
31058       DATA (IPDG5(2,K),K=1,19)
31059      &   / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31060      &     22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31061      &     20311, 12212, 12112/
31062       DATA (IBAM5(2,K),K=1,19)
31063      &   /    40,    41,    44,    45,    57,    58,    59,    60,
31064      &        63,    64,    65,    66,   129,   186,   187,   190,
31065      &       192,   208,   209/
31066
31067 * / DTPAIN /
31068 * internal particle names
31069       DATA BTYPE / 'PROTON  ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31070      &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON  ' , 'NEUTRON ' , 'ANEUTRON' ,
31071      &'MUON+   ' , 'MUON-   ' , 'KAONLONG' , 'PION+   ' , 'PION-   ' ,
31072      &'KAON+   ' , 'KAON-   ' , 'LAMBDA  ' , 'ALAMBDA ' , 'KAONSHRT' ,
31073      &'SIGMA-  ' , 'SIGMA+  ' , 'SIGMAZER' , 'PIZERO  ' , 'KAONZERO' ,
31074      &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31075      &'BLANK   ' /
31076
31077       END
31078
31079 *$ CREATE DT_BLKD46.FOR
31080 *COPY DT_BLKD46
31081 *
31082 *===blkd46=============================================================*
31083 *
31084       BLOCK DATA DT_BLKD46
31085
31086       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31087       SAVE
31088
31089       PARAMETER ( AMELCT = 0.51099906         D-03 )
31090       PARAMETER ( AMMUON = 0.105658389        D+00 )
31091
31092 * particle properties (BAMJET index convention)
31093       CHARACTER*8  ANAME
31094       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31095      &                IICH(210),IIBAR(210),K1(210),K2(210)
31096
31097 * / DTPART /
31098 * Particle  masses Engel version JETSET compatible
31099 C     DATA (AAM(K),K=1,85) /
31100 C    &   .9383D+00, .9383D+00,  AMELCT  ,  AMELCT  , .0000D+00,
31101 C    &   .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON   ,
31102 C    &   AMMUON   , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31103 C    &   .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31104 C    &   .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31105 C    &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31106 C    &   .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31107 C    &   .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31108 C    &   .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31109 C    &   .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31110 C    &   .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31111 C    &   .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31112 C    &   .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31113 C    &   .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31114 C    &   .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31115 C    &   .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31116 C    &   .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01  /
31117 C     DATA (AAM(K),K=86,183) /
31118 C    &   .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31119 C    &   .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31120 C    &   .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31121 C    &   .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31122 C    &   .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31123 C    &   .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31124 C    &   .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31125 C    &   .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31126 C    &   .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31127 C    &   .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31128 C    &   .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31129 C    &   .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31130 C    &   .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31131 C    &   .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31132 C    &   .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31133 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31134 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31135 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31136 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31137 C    &   .1250D+01, .1250D+01, .1250D+01  /
31138 C     DATA (AAM ( I ), I = 184,210 ) /
31139 C    & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31140 C    & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31141 C    & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31142 C    & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31143 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31144 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31145 C    & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31146 C    & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31147 C    & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31148 * sr 25.1.06: particle masses adjusted to Pythia
31149       DATA (AAM(K),K=1,85) /
31150      &   .938270E+00,.938270E+00, AMELCT    , AMELCT    ,.000000E+00,
31151      &   .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON    ,
31152      &    AMMUON    ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31153      &   .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31154      &   .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31155      &     .0000D+00,  .0000D+00,  .0000D+00 , .0000D+00,  .0000D+00,
31156      &   .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31157      &   .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31158      &   .129000E+01,.129000E+01,.129000E+01,  .1421D+01,  .1421D+01,
31159      &     .1421D+01,  .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31160      &     .1820D+01,  .2030D+01,  .1231D+01,  .1232D+01,  .1233D+01,
31161      &     .1234D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,
31162      &     .1500D+01,  .1500D+01,  .1515D+01,  .1515D+01,  .1775D+01,
31163      &     .1775D+01,  .1231D+01,  .1232D+01,  .1233D+01,  .1234D+01,
31164      &     .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1515D+01,
31165      &     .1515D+01,  .2500D+01,  .4890D+00,  .4890D+00,  .4890D+00,
31166      &     .1300D+01,  .1300D+01,  .1300D+01,  .1300D+01,  .2200D+01  /
31167       DATA (AAM(K),K=86,183) /
31168      &     .2200D+01,  .2200D+01,  .2200D+01,  .1700D+01,  .1700D+01,
31169      &     .1700D+01,  .1700D+01,  .1820D+01,  .2030D+01,.957770E+00,
31170      &   .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31171      &   .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31172      &   .138720E+01,.153180E+01,  .1535D+01,.167245E+01,.138280E+01,
31173      &   .138370E+01,.138720E+01,.153180E+01,  .1535D+01,.167245E+01,
31174      &   .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31175      &   .196850E+01,.297980E+01,.200670E+01,  .2010D+01,  .2010D+01,
31176      &   .200670E+01,.211240E+01,.211240E+01,  .3686D+01,.309688E+01,
31177      &   .177700E+01,.177700E+01,  .0000D+00,  .0000D+00,  .0000D+00,
31178      &     .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31179      &   .245350E+01,.245210E+01,  .2560D+01,  .2560D+01,  .2730D+01,
31180      &     .3610D+01,  .3610D+01,  .3790D+01,.228490E+01,.246560E+01,
31181      &     .2460D+01,.245290E+01,.245350E+01,.245210E+01,  .2560D+01,
31182      &     .2560D+01,  .2730D+01,  .3610D+01,  .3610D+01,  .3790D+01,
31183      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31184      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31185      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31186      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31187      &     .1250D+01,  .1250D+01,  .1250D+01  /
31188       DATA (AAM ( I ), I = 184,210 ) /
31189      & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31190      & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31191      & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31192      & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31193      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31194      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31195      & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31196      & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31197      & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31198 * Particle  mean lives
31199       DATA (TAU(K),K=1,183) /
31200      &   .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31201      &   .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31202      &   .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31203      &   .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31204      &   .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31205      &   70*.0000D+00,
31206      &   .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31207      &   .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31208      &   .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31209      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31210      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31211      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31212      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31213      &   .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31214      &   .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31215      &   40*.0000D+00,
31216      &   .0000D+00, .0000D+00, .0000D+00  /
31217       DATA ( TAU ( I ), I = 184,210 ) /
31218      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31219      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31220      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31221      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31222      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31223      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31224      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31225      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31226      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00/
31227 * Resonance width Gamma in GeV
31228       DATA (GA(K),K=  1,85) /
31229      &    30*.0000D+00,
31230      &   .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31231      &   .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31232      &   .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31233      &   .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31234      &   .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31235      &   .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31236      &   .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31237      &   .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31238      &   .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31239      &   .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31240      &   .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00  /
31241       DATA (GA(K),K= 86,183) /
31242      &   .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31243      &   .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31244      &   .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31245      &   .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31246      &   .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31247      &   .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31248      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31249      &   .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31250      &   .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31251      &   50*.0000D+00,
31252      &   .3000D+00, .3000D+00, .3000D+00  /
31253       DATA ( GA ( I ), I = 184,210 ) /
31254      & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31255      & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31256      & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31257      & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31258      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31259      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31260      & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31261      & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31262      & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31263 * Particle  names
31264 * S+1385+Sigma+(1385)    L02030+Lambda0(2030)
31265 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31266 * designation N*@@ means N*@1(@2)
31267       DATA (ANAME(K),K=1,85) /
31268      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31269      &  'ANUE    ','GAM     ','NEU     ','ANEU    ','MUE+    ',
31270      &  'MUE-    ','K0L     ','PI+     ','PI-     ','K+      ',
31271      &  'K-      ','LAM     ','ALAM    ','K0S     ','SIGM-   ',
31272      &  'SIGM+   ','SIGM0   ','PI0     ','K0      ','AK0     ',
31273      &  'BLANK   ','BLANK   ','BLANK   ','BLANK   ','BLANK   ',
31274      &  'ETA550  ','RHO+77  ','RHO077  ','RHO-77  ','OM0783  ',
31275      &  'K*+892  ','K*0892  ','K*-892  ','AK*089  ','KA+125  ',
31276      &  'KA0125  ','KA-125  ','AKA012  ','K*+142  ','K*0142  ',
31277      &  'K*-142  ','AK*014  ','S+1385  ','S01385  ','S-1385  ',
31278      &  'L01820  ','L02030  ','N*++12  ','N*+ 12  ','N*012   ',
31279      &  'N*-12   ','N*++16  ','N*+16   ','N*016   ','N*-16   ',
31280      &  'N*+14   ','N*014   ','N*+15   ','N*015   ','N*+18   ',
31281      &  'N*018   ','AN--12  ','AN*-12  ','AN*012  ','AN*+12  ',
31282      &  'AN--16  ','AN*-16  ','AN*016  ','AN*+16  ','AN*-15  ',
31283      &  'AN*015  ','DE*=24  ','RPI+49  ','RPI049  ','RPI-49  ',
31284      &  'PIN++   ','PIN+0   ','PIN+-   ','PIN-0   ','PPPI    ' /
31285       DATA (ANAME(K),K=86,183) /
31286      &  'PNPI    ','APPPI   ','APNPI   ','K+PPI   ','K-PPI   ',
31287      &  'K+NPI   ','K-NPI   ','S+1820  ','S-2030  ','ETA*    ',
31288      &  'PHI     ','TETA0   ','TETA-   ','ASIG-   ','ASIG0   ',
31289      &  'ASIG+   ','ATETA0  ','ATETA+  ','SIG*+   ','SIG*0   ',
31290      &  'SIG*-   ','TETA*0  ','TETA*   ','OMEGA-  ','ASIG*-  ',
31291      &  'ASIG*0  ','ASIG*+  ','ATET*0  ','ATET*+  ','OMEGA+  ',
31292      &  'D0      ','D+      ','D-      ','AD0     ','F+      ',
31293      &  'F-      ','ETAC    ','D*0     ','D*+     ','D*-     ',
31294      &  'AD*0    ','F*+     ','F*-     ','PSI     ','JPSI    ',
31295      &  'TAU+    ','TAU-    ','NUET    ','ANUET   ','NUEM    ',
31296      &  'ANUEM   ','C0+     ','A+      ','A0      ','C1++    ',
31297      &  'C1+     ','C10     ','S+      ','S0      ','T0      ',
31298      &  'XU++    ','XD+     ','XS+     ','AC0-    ','AA-     ',
31299      &  'AA0     ','AC1--   ','AC1-    ','AC10    ','AS-     ',
31300      &  'AS0     ','AT0     ','AXU--   ','AXD-    ','AXS     ',
31301      &  'C1*++   ','C1*+    ','C1*0    ','S*+     ','S*0     ',
31302      &  'T*0     ','XU*++   ','XD*+    ','XS*+    ','TETA++  ',
31303      &  'AC1*--  ','AC1*-   ','AC1*0   ','AS*-    ','AS*0    ',
31304      &  'AT*0    ','AXU*--  ','AXD*-   ','AXS*-   ','ATET--  ',
31305      &  'RO      ','R+      ','R-      '  /
31306       DATA (    ANAME ( I ), I = 184,210 ) /
31307      &'AN*-14  ','AN*014  ','PI+130  ','PI0130  ','PI-130  ','F01400  ',
31308      &'K*+146  ','K*-146  ','K*0146  ','AK0146  ','L01600  ','AL0160  ',
31309      &'S+1660  ','S01660  ','S-1660  ','AS-166  ','AS0166  ','AS+166  ',
31310      &'X01950  ','X-1950  ','AX0195  ','AX+195  ','OM-225  ','AOM+22  ',
31311      &'N*+14   ','N*014   ','BLANK   '/
31312 * Charge of particles and resonances
31313       DATA (IICH ( I ), I =   1,210 ) /
31314      &  1, -1, -1,  1,  0,  0,  0,  0,  0,  1, -1,  0,  1, -1,  1,
31315      & -1,  0,  0,  0, -1,  1,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31316      &  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0,
31317      & -1,  0,  1,  0, -1,  0,  0,  2,  1,  0, -1,  2,  1,  0, -1,
31318      &  1,  0,  1,  0,  1,  0, -2, -1,  0,  1, -2, -1,  0,  1, -1,
31319      &  0,  1,  1,  0, -1,  2,  1,  0, -1,  2,  1,  0, -1,  2,  0,
31320      &  1, -1,  1, -1,  0,  0,  0, -1, -1,  0,  1,  0,  1,  1,  0,
31321      & -1,  0, -1, -1, -1,  0,  1,  0,  1,  1,  0,  1, -1,  0,  1,
31322      & -1,  0,  0,  1, -1,  0,  1, -1,  0,  0,  1, -1,  0,  0,  0,
31323      &  0,  1,  1,  0,  2,  1,  0,  1,  0,  0,  2,  1,  1, -1, -1,
31324      &  0, -2, -1,  0, -1,  0,  0, -2, -1, -1,  2,  1,  0,  1,  0,
31325      &  0,  2,  1,  1,  2, -2, -1,  0, -1,  0,  0, -2, -1, -1, -2,
31326      &  0,  1, -1, -1,  0,  1,  0, -1,  0,  1, -1,  0,  0,  0,  0,
31327      &  1,  0, -1, -1,  0,  1,  0, -1,  0,  1, -1,  1,  1,  0,  0/
31328 * Particle  baryonic charges
31329       DATA (IIBAR ( I ), I =   1,210 ) /
31330      &  1, -1,  0,  0,  0,  0,  0,  1, -1,  0,  0,  0,  0,  0,  0,
31331      &  0,  1, -1,  0,  1,  1,  1,  0,  0,  0,  0,  0,  0,  0,  0,
31332      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31333      &  0,  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
31334      &  1,  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31335      & -1,  2,  0,  0,  0,  1,  1,  1,  1,  2,  2,  0,  0,  1,  1,
31336      &  1,  1,  1,  1,  0,  0,  1,  1, -1, -1, -1, -1, -1,  1,  1,
31337      &  1,  1,  1,  1, -1, -1, -1, -1, -1, -1,  0,  0,  0,  0,  0,
31338      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31339      &  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1, -1, -1,
31340      & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,  1,  1,  1,  1,  1,
31341      &  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31342      &  0,  0,  0, -1, -1,  0,  0,  0,  0,  0,  0,  0,  0,  1, -1,
31343      &  1,  1,  1, -1, -1, -1,  1,  1, -1, -1,  1, -1,  1,  1,  0/
31344 * First number of decay channels used for resonances
31345 * and decaying particles
31346       DATA K1/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 16, 17,
31347      &  18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31348      &   2*330, 46, 51, 52, 54, 55, 58,
31349 *                                                             50
31350      &  60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31351      & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31352      & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31353 *                                         85
31354      & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31355      & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31356      & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31357      & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31358      & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31359      & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31360      & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31361      & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31362      & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31363      & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31364      & 590, 596, 602 /
31365 * Last number of decay channels used for resonances
31366 * and decaying particles
31367       DATA K2/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 15, 16, 17,
31368      & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31369      & 2* 330, 50, 51, 53, 54, 57,
31370 *                                                                 50
31371      & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31372      & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31373      & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31374 *                                              85
31375      & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31376      & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31377      & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31378      & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31379      & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31380      & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31381      & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31382      & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31383      & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31384      & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31385      & 589, 595, 601, 602 /
31386
31387        END
31388
31389 *$ CREATE DT_BLKD47.FOR
31390 *COPY DT_BLKD47
31391 *
31392 *===blkd47=============================================================*
31393 *
31394       BLOCK DATA DT_BLKD47
31395
31396       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31397       SAVE
31398
31399 * HADRIN: decay channel information
31400       PARAMETER (IDMAX9=602)
31401       CHARACTER*8 ZKNAME
31402       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31403
31404 * Name of decay channel
31405 * Designation N*@ means N*@1(1236)
31406 * @1=# means ++,  @1 = = means --
31407 * Designation  P+/0/- means Pi+/Pi0/Pi- , respectively
31408       DATA (ZKNAME(K),K=  1, 85) /
31409      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31410      &  'ANUE    ','GAM     ','PE-NUE  ','APEANU  ','EANUNU  ',
31411      &  'E-NUAN  ','3PI0    ','PI+-0   ','PIMUNU  ','PIE-NU  ',
31412      &  'MU+NUE  ','MU-NUE  ','MU+NUE  ','PI+PI0  ','PI++-   ',
31413      &  'PI+00   ','M+P0NU  ','E+P0NU  ','MU-NU   ','PI-0    ',
31414      &  'PI+--   ','PI-00   ','M-P0NU  ','E-P0NU  ','PPI-    ',
31415      &  'NPI0    ','PD-NUE  ','PM-NUE  ','APPI+   ','ANPI0   ',
31416      &  'APE+NU  ','APM+NU  ','PI+PI-  ','PI0PI0  ','NPI-    ',
31417      &  'PPI0    ','NPI+    ','LAGA    ','GAGA    ','GAE+E-  ',
31418      &  'GAGA    ','GAGAP0  ','PI000   ','PI+-0   ','PI+-GA  ',
31419      &  'PI+0    ','PI+-    ','PI00    ','PI-0    ','PI+-0   ',
31420      &  'PI+-    ','PI0GA   ','K+PI0   ','K0PI+   ','KOPI0   ',
31421      &  'K+PI-   ','K-PI0   ','AK0PI-  ','AK0PI0  ','K-PI+   ',
31422      &  'K+PI0   ','K0PI+   ','K0PI0   ','K+PI-   ','K-PI0   ',
31423      &  'K0PI-   ','AK0PI0  ','K-PI+   ','K+PI0   ','K0PI+   ',
31424      &  'K+89P0  ','K08PI+  ','K+RO77  ','K0RO+7  ','K+OM07  ',
31425      &  'K+E055  ','K0PI0   ','K+PI+   ','K089P0  ','K+8PI-  '  /
31426       DATA (ZKNAME(K),K= 86,170) /
31427      &  'K0R077  ','K+R-77  ','K+R-77  ','K0OM07  ','K0E055  ',
31428      &  'K-PI0   ','K0PI-   ','K-89P0  ','AK08P-  ','K-R077  ',
31429      &  'AK0R-7  ','K-OM07  ','K-E055  ','AK0PI0  ','K-PI+   ',
31430      &  'AK08P0  ','K-8PI+  ','AK0R07  ','AK0OM7  ','AK0E05  ',
31431      &  'LA0PI+  ','SI0PI+  ','SI+PI0  ','LA0PI0  ','SI+PI-  ',
31432      &  'SI-PI+  ','LA0PI-  ','SI0PI-  ','NEUAK0  ','PK-     ',
31433      &  'SI+PI-  ','SI0PI0  ','SI-PI+  ','LA0ET0  ','S+1PI-  ',
31434      &  'S-1PI+  ','SO1PI0  ','NEUAK0  ','PK-     ','LA0PI0  ',
31435      &  'LA0OM0  ','LA0RO0  ','SI+RO-  ','SI-RO+  ','SI0RO0  ',
31436      &  'LA0ET0  ','SI0ET0  ','SI+PI-  ','SI-PI+  ','SI0PI0  ',
31437      &  'K0S     ','K0L     ','K0S     ','K0L     ','P PI+   ',
31438      &  'P PI0   ','N PI+   ','P PI-   ','N PI0   ','N PI-   ',
31439      &  'P PI+   ','N*#PI0  ','N*+PI+  ','PRHO+   ','P PI0   ',
31440      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31441      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31442      &  'N*-PI+  ','PRHO-   ','NRHO0   ','N PI-   ','N*0PI-  ',
31443      &  'N*-PI0  ','NRHO-   ','PETA0   ','N*#PI-  ','N*+PI0  '  /
31444       DATA (ZKNAME(K),K=171,255) /
31445      &  'N*0PI+  ','PRHO0   ','NRHO+   ','NETA0   ','N*+PI-  ',
31446      &  'N*0PI0  ','N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ',
31447      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31448      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31449      &  'N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ','N PI+   ',
31450      &  'PRHO0   ','NRHO+   ','LAMK+   ','S+ K0   ','S0 K+   ',
31451      &  'PETA0   ','P PI-   ','N PI0   ','PRHO-   ','NRHO0   ',
31452      &  'LAMK0   ','S0 K0   ','S- K+   ','NETA/   ','APPI-   ',
31453      &  'APPI0   ','ANPI-   ','APPI+   ','ANPI0   ','ANPI+   ',
31454      &  'APPI-   ','AN*=P0  ','AN*-P-  ','APRHO-  ','APPI0   ',
31455      &  'ANPI-   ','AN*=P+  ','AN*-P0  ','AN*0P-  ','APRHO0  ',
31456      &  'ANRHO-  ','APPI+   ','ANPI0   ','AN*-P+  ','AN*0P0  ',
31457      &  'AN*+P-  ','APRHO+  ','ANRHO0  ','ANPI+   ','AN*0P+  ',
31458      &  'AN*+P0  ','ANRHO+  ','APPI0   ','ANPI-   ','AN*=P+  ',
31459      &  'AN*-P0  ','AN*0P-  ','APRHO0  ','ANRHO-  ','APPI+,  ',
31460      &  'ANPI0   ','AN*-P+  ','AN*0P0  ','AN*+P-  ','APRHO+  ',
31461      &  'ANRHO0  ','PN*014  ','NN*=14  ','PI+0    ','PI+-    '  /
31462       DATA (ZKNAME(K),K=256,340) /
31463      &  'PI-0    ','P+0     ','N++     ','P+-     ','P00     ',
31464      &  'N+0     ','N+-     ','N00     ','P-0     ','N-0     ',
31465      &  'P--     ','PPPI0   ','PNPI+   ','PNPI0   ','PPPI-   ',
31466      &  'NNPI+   ','APPPI0  ','APNPI+  ','ANNPI0  ','ANPPI-  ',
31467      &  'APNPI0  ','APPPI-  ','ANNPI-  ','K+PPI0  ','K+NPI+  ',
31468      &  'K0PPI0  ','K-PPI0  ','K-NPI+  ','AKPPI-  ','AKNPI0  ',
31469      &  'K+NPI0  ','K+PPI-  ','K0PPI0  ','K0NPI+  ','K-NPI0  ',
31470      &  'K-PPI-  ','AKNPI-  ','PAK0    ','SI+PI0  ','SI0PI+  ',
31471      &  'SI+ETA  ','S+1PI0  ','S01PI+  ','NEUK-   ','LA0PI-  ',
31472      &  'SI-OM0  ','LA0RO-  ','SI0RO-  ','SI-RO0  ','SI-ET0  ',
31473      &  'SI0PI-  ','SI-0    ','BLANC   ','BLANC   ','BLANC   ',
31474      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31475      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31476      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31477      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31478      &  'EPI+-   ','EPI00   ','GAPI+-  ','GAGA*   ','K+-     ',
31479      &  'KLKS    ','PI+-0   ','EGA     ','LPI0    ','LPI     '  /
31480       DATA (ZKNAME(K),K=341,425) /
31481      &  'APPI0   ','ANPI-   ','ALAGA   ','ANPI    ','ALPI0   ',
31482      &  'ALPI+   ','LAPI+   ','SI+PI0  ','SI0PI+  ','LAPI0   ',
31483      &  'SI+PI-  ','SI-PI+  ','LAPI-   ','SI-PI0  ','SI0PI-  ',
31484      &  'TE0PI0  ','TE-PI+  ','TE0PI-  ','TE-PI0  ','TE0PI   ',
31485      &  'TE-PI   ','LAK-    ','ALPI-   ','AS-PI0  ','AS0PI-  ',
31486      &  'ALPI0   ','AS+PI-  ','AS-PI+  ','ALPI+   ','AS+PI0  ',
31487      &  'AS0PI+  ','AT0PI0  ','AT+PI-  ','AT0PI+  ','AT+PI0  ',
31488      &  'AT0PI   ','AT+PI   ','ALK+    ','K-PI+   ','K-PI+0  ',
31489      &  'K0PI+-  ','K0PI0   ','K-PI++  ','AK0PI+  ','K+PI--  ',
31490      &  'K0PI-   ','K+PI-   ','K+PI-0  ','AKPI-+  ','AK0PI0  ',
31491      &  'ETAPIF  ','K++-    ','K+AK0   ','ETAPI-  ','K--+    ',
31492      &  'K-K0    ','PI00    ','PI+-    ','GAGA    ','D0PI0   ',
31493      &  'D0GA    ','D0PI+   ','D+PI0   ','DFGA    ','AD0PI-  ',
31494      &  'D-PI0   ','D-GA    ','AD0PI0  ','AD0GA   ','F+GA    ',
31495      &  'F+GA    ','F-GA    ','F-GA    ','PSPI+-  ','PSPI00  ',
31496      &  'PSETA   ','E+E-    ','MUE+-   ','PI+-0   ','M+NN    ',
31497      &  'E+NN    ','RHO+NT  ','PI+ANT  ','K*+ANT  ','M-NN    '  /
31498       DATA (ZKNAME(K),K=426,510) /
31499      &  'E-NN    ','RHO-NT  ','PI-NT   ','K*-NT   ','NUET    ',
31500      &  'ANUET   ','NUEM    ','ANUEM   ','SI+ETA  ','SI+ET*  ',
31501      &  'PAK0    ','TET0K+  ','SI*+ET  ','N*+AK0  ','N*++K-  ',
31502      &  'LAMRO+  ','SI0RO+  ','SI+RO0  ','SI+OME  ','PAK*0   ',
31503      &  'N*+AK*  ','N*++K*  ','SI+AK0  ','TET0PI  ','SI+AK*  ',
31504      &  'TET0RO  ','SI0AK*  ','SI+K*-  ','TET0OM  ','TET-RO  ',
31505      &  'SI*0AK  ','C0+PI+  ','C0+PI0  ','C0+PI-  ','A+GAM   ',
31506      &  'A0GAM   ','TET0AK  ','TET0K*  ','OM-RO+  ','OM-PI+  ',
31507      &  'C1++AK  ','A+PI+   ','C0+AK0  ','A0PI+   ','A+AK0   ',
31508      &  'T0PI+   ','ASI-ET  ','ASI-E*  ','APK0    ','ATET0K  ',
31509      &  'ASI*-E  ','AN*-K0  ','AN*--K  ','ALAMRO  ','ASI0RO  ',
31510      &  'ASI-RO  ','ASI-OM  ','APK*0   ','AN*-K*  ','AN*--K  ',
31511      &  'ASI-K0  ','ATETPI  ','ASI-K*  ','ATETRO  ','ASI0K*  ',
31512      &  'ASI-K*  ','ATE0OM  ','ATE+RO  ','ASI*0K  ','AC-PI-  ',
31513      &  'AC-PI0  ','AC-PI+  ','AA-GAM  ','AA0GAM  ','ATET0K  ',
31514      &  'ATE0K*  ','AOM+RO  ','AOM+PI  ','AC1--K  ','AA-PI-  ',
31515      &  'AC0-K0  ','AA0PI-  ','AA-K0   ','AT0PI-  ','C1++GA  '  /
31516       DATA (ZKNAME(K),K=511,540) /
31517      &  'C1++GA  ','C10GAM  ','S+GAM   ','S0GAM   ','T0GAM   ',
31518      &  'XU++GA  ','XD+GAM  ','XS+GAM  ','A+AKPI  ','T02PI+  ',
31519      &  'C1++2K  ','AC1--G  ','AC1-GA  ','AC10GA  ','AS-GAM  ',
31520      &  'AS0GAM  ','AT0GAM  ','AXU--G  ','AXD-GA  ','AXS-GA  ',
31521      &  'AA-KPI  ','AT02PI  ','AC1--K  ','RH-PI+  ','RH+PI-  ',
31522      &  'RH3PI0  ','RH0PI+  ','RH+PI0  ','RH0PI-  ','RH-PI0  '  /
31523       DATA (ZKNAME(I),I=541,602)/
31524      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31525      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31526      & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31527      & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31528      & 'PI+PI-','K+K-  ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31529      & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31530      & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31531      & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31532      & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31533 * Weight of decay channel
31534       DATA (WT(K),K=  1, 85) /
31535      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31536      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31537      &   .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31538      &   .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31539      &   .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31540      &   .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31541      &   .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31542      &   .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31543      &   .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31544      &   .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31545      &   .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31546      &   .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31547      &   .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31548      &   .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31549      &   .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31550      &   .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31551      &   .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00  /
31552       DATA (WT(K),K= 86,170) /
31553      &   .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31554      &   .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31555      &   .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31556      &   .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31557      &   .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31558      &   .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31559      &   .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31560      &   .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31561      &   .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31562      &   .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31563      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31564      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31565      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31566      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31567      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31568      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31569      &   .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00  /
31570       DATA (WT(K),K=171,255) /
31571      &   .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31572      &   .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31573      &   .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31574      &   .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31575      &   .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31576      &   .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31577      &   .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31578      &   .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31579      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31580      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31581      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31582      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31583      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31584      &   .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31585      &   .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31586      &   .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31587      &   .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01  /
31588       DATA (WT(K),K=256,340) /
31589      &   .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31590      &   .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31591      &   .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31592      &   .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31593      &   .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31594      &   .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31595      &   .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31596      &   .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31597      &   .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31598      &   .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31599      &   .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31600      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31601      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31602      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31603      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31604      &   .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31605      &   .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01  /
31606       DATA (WT(K),K=341,425) /
31607      &   .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31608      &   .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31609      &   .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31610      &   .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31611      &   .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31612      &   .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31613      &   .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31614      &   .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31615      &   .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31616      &   .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31617      &   .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31618      &   .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31619      &   .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31620      &   .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31621      &   .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31622      &   .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31623      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00  /
31624       DATA (WT(K),K=426,510) /
31625      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31626      &   .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31627      &   .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31628      &   .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31629      &   .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31630      &   .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31631      &   .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31632      &   .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31633      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31634      &   .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31635      &   .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31636      &   .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31637      &   .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31638      &   .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31639      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31640      &   .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31641      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01  /
31642       DATA (WT(K),K=511,540) /
31643      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31644      &   .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31645      &   .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31646      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31647      &   .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31648      &   .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00  /
31649 C
31650       DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31651      & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31652      & .125D+00,  0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31653      & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31654      & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31655      & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31656      & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31657 * Particle numbers in decay channel
31658       DATA (NZK(K,1),K=  1,170) /
31659      &     1,   2,   3,   4,   5,   6,   7,   1,   2,   4,
31660      &     3,  23,  13,  13,  13,  10,  11,  10,  13,  13,
31661      &    13,  10,   4,  11,  14,  14,  14,  11,   3,   1,
31662      &     8,   1,   1,   2,   9,   2,   2,  13,  23,   8,
31663      &     1,   8,  17,   7,   7,   7,  23,  23,  13,  13,
31664      &    13,  13,  23,  14,  13,  13,  23,  15,  24,  24,
31665      &    15,  16,  25,  25,  16,  15,  24,  24,  15,  16,
31666      &    24,  25,  16,  15,  24,  36,  37,  15,  24,  15,
31667      &    15,  24,  15,  37,  36,  24,  15,  24,  24,  16,
31668      &    24,  38,  39,  16,  25,  16,  16,  25,  16,  39,
31669      &    38,  25,  16,  25,  25,  17,  22,  21,  17,  21,
31670      &    20,  17,  22,   8,   1,  21,  22,  20,  17,  48,
31671      &    50,  49,   8,   1,  17,  17,  17,  21,  20,  22,
31672      &    17,  22,  21,  20,  22,  19,  12,  19,  12,   1,
31673      &     1,   8,   1,   8,   8,   1,  53,  54,   1,   1,
31674      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31675      &    56,   1,   8,   8,  55,  56,   8,   1,  53,  54  /
31676       DATA (NZK(K,1),K=171,340) /
31677      &    55,   1,   8,   8,  54,  55,  56,   1,   8,   1,
31678      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31679      &    56,   1,   8,   1,   8,   1,   8,  17,  21,  22,
31680      &     1,   1,   8,   1,   8,  17,  22,  20,   8,   2,
31681      &     2,   9,   2,   9,   9,   2,  67,  68,   2,   2,
31682      &     9,  67,  68,  69,   2,   9,   2,   9,  68,  69,
31683      &    70,   2,   9,   9,  69,  70,   9,   2,   9,  67,
31684      &    68,  69,   2,   9,   2,   9,  68,  69,  70,   2,
31685      &     9,   1,   8,  13,  13,  14,   1,   8,   1,   1,
31686      &     8,   8,   8,   1,   8,   1,   1,   1,   1,   1,
31687      &     8,   2,   2,   9,   9,   2,   2,   9,  15,  15,
31688      &    24,  16,  16,  25,  25,  15,  15,  24,  24,  16,
31689      &    16,  25,   1,  21,  22,  21,  48,  49,   8,  17,
31690      &    20,  17,  22,  20,  20,  22,  20,   0,   0,   0,
31691      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31692      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31693      &    31,  31,  13,   7,  15,  12,  13,  31,  17,  17  /
31694       DATA (NZK(K,1),K=341,510) /
31695      &     2,   9,  18,   9,  18,  18,  17,  21,  22,  17,
31696      &    21,  20,  17,  20,  22,  97,  98,  97,  98,  97,
31697      &    98,  17,  18,  99, 100,  18, 101,  99,  18, 101,
31698      &   100, 102, 103, 102, 103, 102, 103,  18,  16,  16,
31699      &    24,  24,  16,  25,  15,  24,  15,  15,  25,  25,
31700      &    31,  15,  15,  31,  16,  16,  23,  13,   7, 116,
31701      &   116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31702      &   120, 121, 121, 130, 130, 130,   4,  10,  13,  10,
31703      &     4,  32,  13,  36,  11,   3,  34,  14,  38, 133,
31704      &   134, 135, 136,  21,  21,   1,  97, 104,  54,  53,
31705      &    17,  22,  21,  21,   1,  54,  53,  21,  97,  21,
31706      &    97,  22,  21,  97,  98, 105, 137, 137, 137, 138,
31707      &   139,  97,  97, 109, 109, 140, 138, 137, 139, 138,
31708      &   145,  99,  99,   2, 102, 110,  68,  67,  18, 100,
31709      &    99,  99,   2,  68,  67,  99, 102,  99, 102, 100,
31710      &    99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31711      &   113, 115, 115, 152, 150, 149, 151, 150, 157, 140  /
31712       DATA (NZK(K,1),K=511,540) /
31713      &   141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31714      &   140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31715      &   150, 157, 152,  34,  32,  33,  33,  32,  33,  34  /
31716       DATA (NZK(I,1),I=541,602) /  2, 67, 68, 69,  2,  9,  9, 68, 69,
31717      & 70,  2,  9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31718      & 14, 189, 23, 13, 15, 24,  36,  38,  37,  39, 194, 195, 196, 197,
31719      & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31720      & 55, 8, 1, 8, 8, 54, 55, 210/
31721       DATA (NZK(K,2),K=  1,170) /
31722      &     0,   0,   0,   0,   0,   0,   0,   3,   4,   6,
31723      &     5,  23,  14,  11,   3,   5,   5,   5,  23,  13,
31724      &    23,  23,  23,   5,  23,  13,  23,  23,  23,  14,
31725      &    23,   3,  11,  13,  23,   4,  10,  14,  23,  14,
31726      &    23,  13,   7,   7,   4,   7,   7,  23,  14,  14,
31727      &    23,  14,  23,  23,  14,  14,   7,  23,  13,  23,
31728      &    14,  23,  14,  23,  13,  23,  13,  23,  14,  23,
31729      &    14,  23,  13,  23,  13,  23,  13,  33,  32,  35,
31730      &    31,  23,  14,  23,  14,  33,  34,  35,  31,  23,
31731      &    14,  23,  14,  33,  34,  35,  31,  23,  13,  23,
31732      &    13,  33,  32,  35,  31,  13,  13,  23,  23,  14,
31733      &    13,  14,  14,  25,  16,  14,  23,  13,  31,  14,
31734      &    13,  23,  25,  16,  23,  35,  33,  34,  32,  33,
31735      &    31,  31,  14,  13,  23,   0,   0,   0,   0,  13,
31736      &    23,  13,  14,  23,  14,  13,  23,  13,  78,  23,
31737      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31738      &    13,  80,  79,  14,  14,  23,  80,  31,  14,  23  /
31739       DATA (NZK(K,2),K=171,340) /
31740      &    13,  79,  78,  31,  14,  23,  13,  80,  79,  23,
31741      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31742      &    13,  80,  79,  23,  13,  33,  32,  15,  24,  15,
31743      &    31,  14,  23,  34,  33,  24,  24,  15,  31,  14,
31744      &    23,  14,  13,  23,  13,  14,  23,  14,  80,  23,
31745      &    14,  13,  23,  14,  79,  80,  13,  23,  13,  23,
31746      &    14,  78,  79,  13,  13,  23,  78,  23,  14,  13,
31747      &    23,  14,  79,  80,  13,  23,  13,  23,  14,  78,
31748      &    79,  62,  61,  23,  14,  23,  13,  13,  13,  23,
31749      &    13,  13,  23,  14,  14,  14,   1,   8,   8,   1,
31750      &     8,   1,   8,   8,   1,   8,   1,   8,   1,   8,
31751      &     1,   1,   8,   1,   8,   8,   1,   1,   8,   8,
31752      &     1,   8,  25,  23,  13,  31,  23,  13,  16,  14,
31753      &    35,  34,  34,  33,  31,  14,  23,   0,   0,   0,
31754      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31755      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31756      &    13,  23,  14,   7,  16,  19,  14,   7,  23,  14  /
31757       DATA (NZK(K,2),K=341,510) /
31758      &    23,  14,   7,  13,  23,  13,  13,  23,  13,  23,
31759      &    14,  13,  14,  23,  14,  23,  13,  14,  23,  14,
31760      &    23,  16,  14,  23,  14,  23,  14,  13,  13,  23,
31761      &    13,  23,  14,  13,  23,  13,  23,  15,  13,  13,
31762      &    13,  23,  13,  13,  14,  14,  14,  14,  14,  23,
31763      &    13,  16,  25,  14,  15,  24,  23,  14,   7,  23,
31764      &     7,  13,  23,   7,  14,  23,   7,  23,   7,   7,
31765      &     7,   7,   7,  13,  23,  31,   3,  11,  14, 135,
31766      &     5, 134, 134, 134, 136,   6, 133, 133, 133,   0,
31767      &     0,   0,   0,  31,  95,  25,  15,  31,  95,  16,
31768      &    32,  32,  33,  35,  39,  39,  38,  25,  13,  39,
31769      &    32,  39,  38,  35,  32,  39,  13,  23,  14,   7,
31770      &     7,  25,  37,  32,  13,  25,  13,  25,  13,  25,
31771      &    13,  31,  95,  24,  16,  31,  24,  15,  34,  34,
31772      &    33,  35,  37,  37,  36,  24,  14,  37,  34,  37,
31773      &    36,  35,  34,  37,  14,  23,  13,   7,   7,  24,
31774      &    39,  34,  14,  24,  14,  24,  14,  24,  14,   7  /
31775       DATA (NZK(K,2),K=511,540) /
31776      &     7,   7,   7,   7,   7,   7,   7,   7,  25,  13,
31777      &    25,   7,   7,   7,   7,   7,   7,   7,   7,   7,
31778      &    24,  14,  24,  13,  14,  23,  13,  23,  14,  23  /
31779       DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31780      & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31781      & 14, 14, 23, 14, 16, 25,
31782      & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31783      & 23, 13, 14, 23,  0 /
31784       DATA (NZK(K,3),K=  1,170) /
31785      &     0,   0,   0,   0,   0,   0,   0,   5,   6,   5,
31786      &     6,  23,  23,   5,   5,   0,   0,   0,   0,  14,
31787      &    23,   5,   5,   0,   0,  14,  23,   5,   5,   0,
31788      &     0,   5,   5,   0,   0,   5,   5,   0,   0,   0,
31789      &     0,   0,   0,   0,   3,   0,   7,  23,  23,   7,
31790      &     0,   0,   0,   0,  23,   0,   0,   0,   0,   0,
31791      &     110*0   /
31792       DATA (NZK(K,3),K=171,340) /
31793      &     80*0,
31794      &     0,   0,   0,   0,   0,   0,  23,  13,  14,  23,
31795      &    23,  14,  23,  23,  23,  14,  23,  13,  23,  14,
31796      &    13,  23,  13,  23,  14,  23,  14,  14,  23,  13,
31797      &    13,  23,  13,  14,  23,  23,  14,  23,  13,  23,
31798      &    14,  14,   0,   0,   0,   0,   0,   0,   0,   0,
31799      &     30*0,
31800      &    14,  23,   7,   0,   0,   0,  23,   0,   0,   0  /
31801       DATA (NZK(K,3),K=341,510) /
31802      &     30*0,
31803      &     0,   0,   0,   0,   0,   0,   0,   0,   0,  23,
31804      &    14,   0,  13,   0,  14,   0,   0,  23,  13,   0,
31805      &     0,  15,   0,   0,  16,   0,   0,   0,   0,   0,
31806      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31807      &     0,   0,   0,  14,  23,   0,   0,   0,  23, 134,
31808      &   134,   0,   0,   0, 133, 133,   0,   0,   0,   0,
31809      &     80*0  /
31810       DATA (NZK(K,3),K=511,540) /
31811      &     0,   0,   0,   0,   0,   0,   0,   0,  13,  13,
31812      &    25,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31813      &    14,  14,  24,   0,   0,   0,   0,   0,   0,   0  /
31814       DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31815      & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31816
31817       END
31818
31819 *$ CREATE DT_XHOINI.FOR
31820 *COPY DT_XHOINI
31821 *
31822 *====phoini============================================================*
31823 *
31824       SUBROUTINE DT_XHOINI
31825 C     SUBROUTINE DT_PHOINI
31826
31827       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31828       SAVE
31829
31830       PARAMETER ( LINP = 10 ,
31831      &            LOUT = 6 ,
31832      &            LDAT = 9 )
31833
31834       RETURN
31835       END
31836
31837 *$ CREATE DT_XVENTB.FOR
31838 *COPY DT_XVENTB
31839 *
31840 *====eventb============================================================*
31841 *
31842       SUBROUTINE DT_XVENTB(NCSY,IREJ)
31843 C     SUBROUTINE DT_EVENTB(NCSY,IREJ)
31844
31845       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31846       SAVE
31847
31848       PARAMETER ( LINP = 10 ,
31849      &            LOUT = 6 ,
31850      &            LDAT = 9 )
31851
31852       WRITE(LOUT,1000)
31853  1000 FORMAT(1X,'EVENTB:   PHOJET-package requested but not linked!')
31854       STOP
31855
31856       END
31857
31858 *$ CREATE DT_XVENT.FOR
31859 *COPY DT_XVENT
31860 *
31861 *===event==============================================================*
31862 *
31863       SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
31864 C     SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
31865
31866       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31867       SAVE
31868
31869       DIMENSION PP(4),PT(4)
31870
31871       RETURN
31872       END
31873
31874 *$ CREATE DT_XOHISX.FOR
31875 *COPY DT_XOHISX
31876 *
31877 *===pohisx=============================================================*
31878 *
31879       SUBROUTINE DT_XOHISX(I,X)
31880 C     SUBROUTINE POHISX(I,X)
31881
31882       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31883       SAVE
31884
31885       RETURN
31886       END
31887
31888 *$ CREATE PHO_LHIST.FOR
31889 *COPY PHO_LHIST
31890 *
31891 *===poluhi=============================================================*
31892 *
31893       SUBROUTINE PHO_LHIST(I,X)
31894
31895 **
31896
31897       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31898       SAVE
31899
31900       RETURN
31901       END
31902
31903 *$ CREATE PDFSET.FOR
31904 *COPY PDFSET
31905 *
31906 C**********************************************************************
31907 C
31908 C   dummy subroutines, remove to link PDFLIB
31909 C
31910 C**********************************************************************
31911       SUBROUTINE PDFSET(PARAM,VALUE)
31912       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31913       DIMENSION PARAM(20),VALUE(20)
31914       CHARACTER*20 PARAM
31915       END
31916
31917 *$ CREATE STRUCTM.FOR
31918 *COPY STRUCTM
31919 *
31920       SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31921       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31922       END
31923
31924 *$ CREATE STRUCTP.FOR
31925 *COPY STRUCTP
31926 *
31927       SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31928       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31929       END
31930
31931 *$ CREATE DT_DIQBRK.FOR
31932 *COPY DT_DIQBRK
31933 *
31934 *===diqbrk=============================================================*
31935 *
31936       SUBROUTINE DT_XIQBRK
31937 C     SUBROUTINE DT_DIQBRK
31938
31939       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31940       SAVE
31941
31942       STOP 'diquark-breaking not implemeted !'
31943
31944       RETURN
31945       END
31946 *$ CREATE DT_ELHAIN.FOR
31947 *COPY DT_ELHAIN
31948 *
31949 *===elhain=============================================================*
31950 *
31951       SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
31952
31953 ************************************************************************
31954 * Elastic hadron-hadron scattering.                                    *
31955 * This is a revised version of the original.                           *
31956 * This version dated 03.04.98 is written by S. Roesler                 *
31957 ************************************************************************
31958
31959       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31960       SAVE
31961
31962       PARAMETER ( LINP = 10 ,
31963      &            LOUT = 6 ,
31964      &            LDAT = 9 )
31965
31966       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
31967      &           TINY10=1.0D-10)
31968
31969       PARAMETER (ENNTHR = 3.5D0)
31970       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
31971      &           BLOWB=0.05D0,BHIB=0.2D0,
31972      &           BLOWM=0.1D0, BHIM=2.0D0)
31973
31974 * particle properties (BAMJET index convention)
31975       CHARACTER*8  ANAME
31976       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31977      &                IICH(210),IIBAR(210),K1(210),K2(210)
31978
31979 * final state from HADRIN interaction
31980       PARAMETER (MAXFIN=10)
31981       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
31982      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
31983
31984 C     DATA TSLOPE /10.0D0/
31985
31986       IREJ = 0
31987
31988     1 CONTINUE
31989
31990       PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
31991       EKIN = ELAB-AAM(IP)
31992 *   kinematical quantities in cms of the hadrons
31993       AMP2 = AAM(IP)**2
31994       AMT2 = AAM(IT)**2
31995       S    = AMP2+AMT2+TWO*ELAB*AAM(IT)
31996       ECM  = SQRT(S)
31997       ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
31998       PCM  = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
31999
32000 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
32001       IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
32002      &     ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
32003 *   TSAMCS treats pp and np only, therefore change pn into np and
32004 *   nn into pp
32005          IF (IT.EQ.1) THEN
32006             KPROJ = IP
32007          ELSE
32008             KPROJ = 8
32009             IF (IP.EQ.8) KPROJ = 1
32010          ENDIF
32011          CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
32012          T = TWO*PCM**2*(CTCMS-ONE)
32013
32014 * very crude treatment otherwise: sample t from exponential dist.
32015       ELSE
32016 *   momentum transfer t
32017          TMAX = TWO*TWO*PCM**2
32018          RR = (PLAB-PLOWH)/(PHIH-PLOWH)
32019          IF (IIBAR(IP).NE.0) THEN
32020             TSLOPE = BLOWB+RR*(BHIB-BLOWB)
32021          ELSE
32022             TSLOPE = BLOWM+RR*(BHIM-BLOWM)
32023          ENDIF
32024          FMAX = EXP(-TSLOPE*TMAX)-ONE
32025          R = DT_RNDM(RR)
32026          T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
32027          IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
32028       ENDIF
32029
32030 *   target hadron in Lab after scattering
32031       ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
32032       PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
32033       IF (PLRH(2).LE.TINY10) THEN
32034 C        WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
32035          GOTO 1
32036       ENDIF
32037 *   projectile hadron in Lab after scattering
32038       ELRH(1) = ELAB+AAM(IT)-ELRH(2)
32039       PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
32040 *   scattering angle of projectile in Lab
32041       CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
32042       STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
32043       CALL DT_DSFECF(SPLABP,CPLABP)
32044 *   direction cosines of projectile in Lab
32045       CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
32046      &                          CXRH(1),CYRH(1),CZRH(1))
32047 *   scattering angle of target in Lab
32048       PLLABT = PLAB-CTLABP*PLRH(1)
32049       CTLABT = PLLABT/PLRH(2)
32050       STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
32051 *   direction cosines of target in Lab
32052       CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
32053      &                            CXRH(2),CYRH(2),CZRH(2))
32054 *   fill /HNFSPA/
32055       IRH = 2
32056       ITRH(1) = IP
32057       ITRH(2) = IT
32058
32059       RETURN
32060       END
32061
32062 *$ CREATE DT_TSAMCS.FOR
32063 *COPY DT_TSAMCS
32064 *
32065 *===tsamcs=============================================================*
32066 *
32067       SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
32068
32069 ************************************************************************
32070 * Sampling of cos(theta) for nucleon-proton scattering according to    *
32071 * hetkfa2/bertini parametrization.                                     *
32072 * This is a revised version of the original (HJM 24/10/88)             *
32073 * This version dated 28.10.95 is written by S. Roesler                 *
32074 ************************************************************************
32075
32076       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32077       SAVE
32078
32079       PARAMETER ( LINP = 10 ,
32080      &            LOUT = 6 ,
32081      &            LDAT = 9 )
32082
32083       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
32084      &           TINY10=1.0D-10)
32085
32086       DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
32087       DIMENSION PDCI(60),PDCH(55)
32088
32089       DATA (DCLIN(I),I=1,80) /
32090      &     5.000D-01,  1.000D+00,  0.000D+00,  1.000D+00,  0.000D+00,
32091      &     4.993D-01,  9.881D-01,  5.963D-02,  9.851D-01,  5.945D-02,
32092      &     4.936D-01,  8.955D-01,  5.224D-01,  8.727D-01,  5.091D-01,
32093      &     4.889D-01,  8.228D-01,  8.859D-01,  7.871D-01,  8.518D-01,
32094      &     4.874D-01,  7.580D-01,  1.210D+00,  7.207D-01,  1.117D+00,
32095      &     4.912D-01,  6.969D-01,  1.516D+00,  6.728D-01,  1.309D+00,
32096      &     5.075D-01,  6.471D-01,  1.765D+00,  6.667D-01,  1.333D+00,
32097      &     5.383D-01,  6.054D-01,  1.973D+00,  7.059D-01,  1.176D+00,
32098      &     5.397D-01,  5.990D-01,  2.005D+00,  7.023D-01,  1.191D+00,
32099      &     5.336D-01,  6.083D-01,  1.958D+00,  6.959D-01,  1.216D+00,
32100      &     5.317D-01,  6.075D-01,  1.962D+00,  6.897D-01,  1.241D+00,
32101      &     5.300D-01,  6.016D-01,  1.992D+00,  6.786D-01,  1.286D+00,
32102      &     5.281D-01,  6.063D-01,  1.969D+00,  6.786D-01,  1.286D+00,
32103      &     5.280D-01,  5.960D-01,  2.020D+00,  6.667D-01,  1.333D+00,
32104      &     5.273D-01,  5.920D-01,  2.040D+00,  6.604D-01,  1.358D+00,
32105      &     5.273D-01,  5.862D-01,  2.069D+00,  6.538D-01,  1.385D+00/
32106       DATA (DCLIN(I),I=81,160) /
32107      &     5.223D-01,  5.980D-01,  2.814D+00,  6.538D-01,  1.385D+00,
32108      &     5.202D-01,  5.969D-01,  2.822D+00,  6.471D-01,  1.412D+00,
32109      &     5.183D-01,  5.881D-01,  2.883D+00,  6.327D-01,  1.469D+00,
32110      &     5.159D-01,  5.866D-01,  2.894D+00,  6.250D-01,  1.500D+00,
32111      &     5.133D-01,  5.850D-01,  2.905D+00,  6.170D-01,  1.532D+00,
32112      &     5.106D-01,  5.833D-01,  2.917D+00,  6.087D-01,  1.565D+00,
32113      &     5.084D-01,  5.801D-01,  2.939D+00,  6.000D-01,  1.600D+00,
32114      &     5.063D-01,  5.763D-01,  2.966D+00,  5.909D-01,  1.636D+00,
32115      &     5.036D-01,  5.730D-01,  2.989D+00,  5.814D-01,  1.674D+00,
32116      &     5.014D-01,  5.683D-01,  3.022D+00,  5.714D-01,  1.714D+00,
32117      &     4.986D-01,  5.641D-01,  3.051D+00,  5.610D-01,  1.756D+00,
32118      &     4.964D-01,  5.580D-01,  3.094D+00,  5.500D-01,  1.800D+00,
32119      &     4.936D-01,  5.573D-01,  3.099D+00,  5.431D-01,  1.827D+00,
32120      &     4.909D-01,  5.509D-01,  3.144D+00,  5.313D-01,  1.875D+00,
32121      &     4.885D-01,  5.512D-01,  3.142D+00,  5.263D-01,  1.895D+00,
32122      &     4.857D-01,  5.437D-01,  3.194D+00,  5.135D-01,  1.946D+00/
32123       DATA (DCLIN(I),I=161,195) /
32124      &     4.830D-01,  5.353D-01,  3.253D+00,  5.000D-01,  2.000D+00,
32125      &     4.801D-01,  5.323D-01,  3.274D+00,  4.915D-01,  2.034D+00,
32126      &     4.770D-01,  5.228D-01,  3.341D+00,  4.767D-01,  2.093D+00,
32127      &     4.738D-01,  5.156D-01,  3.391D+00,  4.643D-01,  2.143D+00,
32128      &     4.701D-01,  5.010D-01,  3.493D+00,  4.444D-01,  2.222D+00,
32129      &     4.672D-01,  4.990D-01,  3.507D+00,  4.375D-01,  2.250D+00,
32130      &     4.634D-01,  4.856D-01,  3.601D+00,  4.194D-01,  2.323D+00/
32131
32132       DATA PDCI /
32133      &     4.400D+02,  1.896D-01,  1.931D-01,  1.982D-01,  1.015D-01,
32134      &     1.029D-01,  4.180D-02,  4.228D-02,  4.282D-02,  4.350D-02,
32135      &     2.204D-02,  2.236D-02,  5.900D+02,  1.433D-01,  1.555D-01,
32136      &     1.774D-01,  1.000D-01,  1.128D-01,  5.132D-02,  5.600D-02,
32137      &     6.158D-02,  6.796D-02,  3.660D-02,  3.820D-02,  6.500D+02,
32138      &     1.192D-01,  1.334D-01,  1.620D-01,  9.527D-02,  1.141D-01,
32139      &     5.283D-02,  5.952D-02,  6.765D-02,  7.878D-02,  4.796D-02,
32140      &     6.957D-02,  8.000D+02,  4.872D-02,  6.694D-02,  1.152D-01,
32141      &     9.348D-02,  1.368D-01,  6.912D-02,  7.953D-02,  9.577D-02,
32142      &     1.222D-01,  7.755D-02,  9.525D-02,  1.000D+03,  3.997D-02,
32143      &     5.456D-02,  9.804D-02,  8.084D-02,  1.208D-01,  6.520D-02,
32144      &     8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,  1.093D-01/
32145
32146       DATA PDCH /
32147      &     1.000D+03,  9.453D-02,  9.804D-02,  8.084D-02,  1.208D-01,
32148      &     6.520D-02,  8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,
32149      &     1.093D-01,  1.400D+03,  1.072D-01,  7.450D-02,  6.645D-02,
32150      &     1.136D-01,  6.750D-02,  8.580D-02,  1.110D-01,  1.530D-01,
32151      &     1.010D-01,  1.350D-01,  2.170D+03,  4.004D-02,  3.013D-02,
32152      &     2.664D-02,  5.511D-02,  4.240D-02,  7.660D-02,  1.364D-01,
32153      &     2.300D-01,  1.670D-01,  2.010D-01,  2.900D+03,  1.870D-02,
32154      &     1.804D-02,  1.320D-02,  2.970D-02,  2.860D-02,  5.160D-02,
32155      &     1.020D-01,  2.400D-01,  2.250D-01,  3.370D-01,  4.400D+03,
32156      &     1.196D-03,  8.784D-03,  1.517D-02,  2.874D-02,  2.488D-02,
32157      &     4.464D-02,  8.330D-02,  2.008D-01,  2.360D-01,  3.567D-01/
32158
32159       DATA (DCHN(I),I=1,90) /
32160      &     4.770D-01,  4.750D-01,  4.715D-01,  4.685D-01,  4.650D-01,
32161      &     4.610D-01,  4.570D-01,  4.550D-01,  4.500D-01,  4.450D-01,
32162      &     4.405D-01,  4.350D-01,  4.300D-01,  4.250D-01,  4.200D-01,
32163      &     4.130D-01,  4.060D-01,  4.000D-01,  3.915D-01,  3.840D-01,
32164      &     3.760D-01,  3.675D-01,  3.580D-01,  3.500D-01,  3.400D-01,
32165      &     3.300D-01,  3.200D-01,  3.100D-01,  3.000D-01,  2.900D-01,
32166      &     2.800D-01,  2.700D-01,  2.600D-01,  2.500D-01,  2.400D-01,
32167      &     2.315D-01,  2.240D-01,  2.150D-01,  2.060D-01,  2.000D-01,
32168      &     1.915D-01,  1.850D-01,  1.780D-01,  1.720D-01,  1.660D-01,
32169      &     1.600D-01,  1.550D-01,  1.500D-01,  1.450D-01,  1.400D-01,
32170      &     1.360D-01,  1.320D-01,  1.280D-01,  1.250D-01,  1.210D-01,
32171      &     1.180D-01,  1.150D-01,  1.120D-01,  1.100D-01,  1.070D-01,
32172      &     1.050D-01,  1.030D-01,  1.010D-01,  9.900D-02,  9.700D-02,
32173      &     9.550D-02,  9.480D-02,  9.400D-02,  9.200D-02,  9.150D-02,
32174      &     9.100D-02,  9.000D-02,  8.990D-02,  8.900D-02,  8.850D-02,
32175      &     8.750D-02,  8.700D-02,  8.650D-02,  8.550D-02,  8.500D-02,
32176      &     8.499D-02,  8.450D-02,  8.350D-02,  8.300D-02,  8.250D-02,
32177      &     8.150D-02,  8.100D-02,  8.030D-02,  8.000D-02,  7.990D-02/
32178       DATA (DCHN(I),I=91,143) /
32179      &     7.980D-02,  7.950D-02,  7.900D-02,  7.860D-02,  7.800D-02,
32180      &     7.750D-02,  7.650D-02,  7.620D-02,  7.600D-02,  7.550D-02,
32181      &     7.530D-02,  7.500D-02,  7.499D-02,  7.498D-02,  7.480D-02,
32182      &     7.450D-02,  7.400D-02,  7.350D-02,  7.300D-02,  7.250D-02,
32183      &     7.230D-02,  7.200D-02,  7.100D-02,  7.050D-02,  7.020D-02,
32184      &     7.000D-02,  6.999D-02,  6.995D-02,  6.993D-02,  6.991D-02,
32185      &     6.990D-02,  6.870D-02,  6.850D-02,  6.800D-02,  6.780D-02,
32186      &     6.750D-02,  6.700D-02,  6.650D-02,  6.630D-02,  6.600D-02,
32187      &     6.550D-02,  6.525D-02,  6.510D-02,  6.500D-02,  6.499D-02,
32188      &     6.498D-02,  6.496D-02,  6.494D-02,  6.493D-02,  6.490D-02,
32189      &     6.488D-02,  6.485D-02,  6.480D-02/
32190
32191       DATA DCHNA /
32192      &     6.300D+02,  7.810D-02,  1.421D-01,  1.979D-01,  2.479D-01,
32193      &     3.360D-01,  5.400D-01,  7.236D-01,  1.000D+00,  1.540D+03,
32194      &     2.225D-01,  3.950D-01,  5.279D-01,  6.298D-01,  7.718D-01,
32195      &     9.405D-01,  9.835D-01,  1.000D+00,  2.560D+03,  2.625D-01,
32196      &     4.550D-01,  5.963D-01,  7.020D-01,  8.380D-01,  9.603D-01,
32197      &     9.903D-01,  1.000D+00,  3.520D+03,  4.250D-01,  6.875D-01,
32198      &     8.363D-01,  9.163D-01,  9.828D-01,  1.000D+00,  1.000D+00,
32199      &     1.000D+00/
32200
32201       DATA DCHNB /
32202      &     6.300D+02,  3.800D-02,  7.164D-02,  1.275D-01,  2.171D-01,
32203      &     3.227D-01,  4.091D-01,  5.051D-01,  6.061D-01,  7.074D-01,
32204      &     8.434D-01,  1.000D+00,  2.040D+03,  1.200D-01,  2.115D-01,
32205      &     3.395D-01,  5.295D-01,  7.251D-01,  8.511D-01,  9.487D-01,
32206      &     9.987D-01,  1.000D+00,  1.000D+00,  1.000D+00,  2.200D+03,
32207      &     1.344D-01,  2.324D-01,  3.754D-01,  5.674D-01,  7.624D-01,
32208      &     8.896D-01,  9.808D-01,  1.000D+00,  1.000D+00,  1.000D+00,
32209      &     1.000D+00,  2.850D+03,  2.330D-01,  4.130D-01,  6.610D-01,
32210      &     9.010D-01,  9.970D-01,  1.000D+00,  1.000D+00,  1.000D+00,
32211      &     1.000D+00,  1.000D+00,  1.000D+00,  3.500D+03,  3.300D-01,
32212      &     5.450D-01,  7.950D-01,  1.000D+00,  1.000D+00,  1.000D+00,
32213      &     1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00/
32214
32215       CST = ONE
32216       IF (EKIN.GT.3.5D0) RETURN
32217 C
32218       IF(KPROJ.EQ.8) GOTO 101
32219       IF(KPROJ.EQ.1) GOTO 102
32220 C*                                             INVALID REACTION
32221       WRITE(LOUT,'(A,I5/A)')
32222      &        ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
32223      &        ' COS(THETA) = 1D0 RETURNED'
32224       RETURN
32225 C-------------------------------- NP ELASTIC SCATTERING----------
32226 101   CONTINUE
32227       IF (EKIN.GT.0.740D0)GOTO 1000
32228       IF (EKIN.LT.0.300D0)THEN
32229 C                                 EKIN .LT. 300 MEV
32230          IDAT=1
32231       ELSE
32232 C                                 300 MEV < EKIN < 740 MEV
32233          IDAT=6
32234       END IF
32235 C
32236       ENER=EKIN
32237       IE=INT(ABS(ENER/0.020D0))
32238       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32239 C                                            FORWARD/BACKWARD DECISION
32240       K=IDAT+5*IE
32241       BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32242       IF (DT_RNDM(CST).LT.BWFW)THEN
32243          VALUE2=-1D0
32244          K=K+1
32245       ELSE
32246          VALUE2=1D0
32247          K=K+3
32248       END IF
32249 C
32250       COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32251       RND=DT_RNDM(COEF)
32252 C
32253       IF(RND.LT.COEF)THEN
32254          CST=DT_RNDM(RND)
32255          CST=CST*VALUE2
32256       ELSE
32257          R1=DT_RNDM(CST)
32258          R2=DT_RNDM(R1)
32259          R3=DT_RNDM(R2)
32260          R4=DT_RNDM(R3)
32261 C
32262          IF(VALUE2.GT.0.0)THEN
32263             CST=MAX(R1,R2,R3,R4)
32264             GOTO 1500
32265          ELSE
32266             R5=DT_RNDM(R4)
32267 C
32268             IF (IDAT.EQ.1)THEN
32269                CST=-MAX(R1,R2,R3,R4,R5)
32270             ELSE
32271                R6=DT_RNDM(R5)
32272                R7=DT_RNDM(R6)
32273                CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
32274             END IF
32275 C
32276          END IF
32277 C
32278       END IF
32279 C
32280       GOTO 1500
32281 C
32282 C********                                EKIN  .GT.  0.74 GEV
32283 C
32284 1000  ENER=EKIN - 0.66D0
32285 C     IE=ABS(ENER/0.02)
32286       IE=INT(ENER/0.02D0)
32287       EMEV=EKIN*1D3
32288 C
32289       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32290       K=IE
32291       BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
32292       RND=DT_RNDM(BWFW)
32293 C                                        FORWARD NEUTRON
32294       IF (RND.GE.BWFW)THEN
32295          DO 1200 K=10,36,9
32296            IF (DCHNA(K).GT.EMEV) THEN
32297               UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
32298               UNIV=DT_RNDM(UNIVE)
32299               DO 1100 I=1,8
32300                  II=K+I
32301                  P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
32302 C
32303                  IF (P.GT.UNIV)THEN
32304                     UNIV=DT_RNDM(UNIVE)
32305                     FLTI=DBLE(I)-UNIV
32306                     GOTO(290,290,290,290,330,340,350,360) I
32307                  END IF
32308  1100         CONTINUE
32309            END IF
32310  1200    CONTINUE
32311 C
32312       ELSE
32313 C                                        BACKWARD NEUTRON
32314          DO 1400 K=13,60,12
32315             IF (DCHNB(K).GT.EMEV) THEN
32316                UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
32317                UNIV=DT_RNDM(UNIVE)
32318                DO 1300 I=1,11
32319                  II=K+I
32320                  P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
32321 C
32322                  IF (P.GT.UNIV)THEN
32323                    UNIV=DT_RNDM(P)
32324                    FLTI=DBLE(I)-UNIV
32325                    GOTO(120,120,140,150,160,160,180,190,200,210,220) I
32326                  END IF
32327  1300          CONTINUE
32328             END IF
32329  1400    CONTINUE
32330       END IF
32331 C
32332 120   CST=1.0D-2*FLTI-1.0D0
32333       GOTO 1500
32334 140   CST=2.0D-2*UNIV-0.98D0
32335       GOTO 1500
32336 150   CST=4.0D-2*UNIV-0.96D0
32337       GOTO 1500
32338 160   CST=6.0D-2*FLTI-1.16D0
32339       GOTO 1500
32340 180   CST=8.0D-2*UNIV-0.80D0
32341       GOTO 1500
32342 190   CST=1.0D-1*UNIV-0.72D0
32343       GOTO 1500
32344 200   CST=1.2D-1*UNIV-0.62D0
32345       GOTO 1500
32346 210   CST=2.0D-1*UNIV-0.50D0
32347       GOTO 1500
32348 220   CST=3.0D-1*(UNIV-1.0D0)
32349       GOTO 1500
32350 C
32351 290   CST=1.0D0-2.5d-2*FLTI
32352       GOTO 1500
32353 330   CST=0.85D0+0.5D-1*UNIV
32354       GOTO 1500
32355 340   CST=0.70D0+1.5D-1*UNIV
32356       GOTO 1500
32357 350   CST=0.50D0+2.0D-1*UNIV
32358       GOTO 1500
32359 360   CST=0.50D0*UNIV
32360 C
32361 1500  RETURN
32362 C
32363 C-----------------------------------  PP ELASTIC SCATTERING -------
32364 C
32365  102  CONTINUE
32366       EMEV=EKIN*1D3
32367 C
32368       IF (EKIN.LE.0.500D0) THEN
32369          RND=DT_RNDM(EMEV)
32370          CST=2.0D0*RND-1.0D0
32371          RETURN
32372 C
32373       ELSEIF (EKIN.LT.1.0D0) THEN
32374          DO 2200 K=13,60,12
32375             IF (PDCI(K).GT.EMEV) THEN
32376                UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
32377                UNIV=DT_RNDM(UNIVE)
32378                SUM=0
32379                DO 2100 I=1,11
32380                  II=K+I
32381                  SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
32382 C
32383                  IF (UNIV.LT.SUM)THEN
32384                    UNIV=DT_RNDM(SUM)
32385                    FLTI=DBLE(I)-UNIV
32386                    GOTO(55,55,55,60,60,65,65,65,65,70,70) I
32387                  END IF
32388  2100          CONTINUE
32389             END IF
32390  2200    CONTINUE
32391       ELSE
32392          DO 2400 K=12,55,11
32393             IF (PDCH(K).GT.EMEV) THEN
32394               UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
32395               UNIV=DT_RNDM(UNIVE)
32396               SUM=0.0D0
32397               DO 2300 I=1,10
32398                 II=K+I
32399                 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
32400 C
32401                 IF (UNIV.LT.SUM)THEN
32402                   UNIV=DT_RNDM(SUM)
32403                   FLTI=UNIV+DBLE(I)
32404                   GOTO(50,55,60,60,65,65,65,65,70,70) I
32405                 END IF
32406  2300         CONTINUE
32407             END IF
32408  2400    CONTINUE
32409       END IF
32410 C
32411 50    CST=0.4D0*UNIV
32412       GOTO 2500
32413 55    CST=0.2D0*FLTI
32414       GOTO 2500
32415 60    CST=0.3D0+0.1D0*FLTI
32416       GOTO 2500
32417 65    CST=0.6D0+0.04D0*FLTI
32418       GOTO 2500
32419 70    CST=0.78D0+0.02D0*FLTI
32420 C
32421 2500  CONTINUE
32422       IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
32423 C
32424       RETURN
32425       END
32426
32427 *$ CREATE DT_DHADRI.FOR
32428 *COPY DT_DHADRI
32429 *
32430 *===dhadri=============================================================*
32431 *
32432       SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
32433
32434       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32435       SAVE
32436
32437       PARAMETER ( LINP = 10 ,
32438      &            LOUT = 6 ,
32439      &            LDAT = 9 )
32440
32441 C
32442 C-----------------------------
32443 C*** INPUT VARIABLES LIST:
32444 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
32445 C*** GEV/C LABORATORY MOMENTUM REGION
32446 C*** N    - PROJECTILE HADRON INDEX
32447 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
32448 C*** ELAB - LABORATORY ENERGY OF N (GEV)
32449 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
32450 C*** ITTA - TARGET NUCLEON INDEX
32451 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
32452 C  IR COUNTS THE NUMBER OF PRODUCED PARTICLES
32453 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
32454 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
32455 C*** RESPECT., UNITS (GEV/C AND GEV)
32456 C----------------------------
32457
32458       COMMON /HNGAMR/ REDU,AMO,AMM(15)
32459
32460       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32461
32462       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32463      &                NRK(2,268),NURE(30,2)
32464
32465 * particle properties (BAMJET index convention),
32466 * (dublicate of DTPART for HADRIN)
32467       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32468      &                K1H(110),K2H(110)
32469
32470       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32471
32472       COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
32473      &                ITS(149),IS
32474
32475       COMMON /HNDRUN/ RUNTES,EFTES
32476
32477 * particle properties (BAMJET index convention)
32478       CHARACTER*8  ANAME
32479       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
32480      &                IICH(210),IIBAR(210),K1(210),K2(210)
32481
32482 * final state from HADRIN interaction
32483       PARAMETER (MAXFIN=10)
32484       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
32485      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
32486
32487       DIMENSION ITPRF(110)
32488       DATA NNN/0/
32489       DATA UMODA/0./
32490       DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
32491       LOWP=0
32492       IF (N.LE.0.OR.N.GE.111)N=1
32493       IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
32494         GOTO 280
32495 *       WRITE (6,1000)
32496 *    +  ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
32497 *       STOP
32498 *1000   FORMAT (3(5H ****/),A,2I4,3(5H ****/))
32499 *    +  45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
32500       ENDIF
32501       IATMPT=0
32502       IF (ABS(PLAB-5.0D0).LT.4.99999D0)                        GO TO 20
32503 C     IF(IPRI.GE.1) WRITE (6,1010) PLAB
32504 C     STOP
32505  1010 FORMAT ( '  PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
32506      + ALLOWED REGION, PLAB=',1E15.5)
32507
32508    20 CONTINUE
32509       UMODAT=N*1.11111D0+ITTA*2.19291D0
32510       IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
32511       UMODA=UMODAT
32512    30 IATMPT=0
32513       LOWP=LOWP+1
32514    40 CONTINUE
32515       IMACH=0
32516       REDU=2.0D0
32517       IF (LOWP.GT.20) THEN
32518 C        WRITE(LOUT,*) ' jump 1'
32519          GO TO 280
32520       ENDIF
32521       NNN=N
32522       IF (NNN.EQ.N)                                             GO TO 50
32523       RUNTES=0.0D0
32524       EFTES=0.0D0
32525    50 CONTINUE
32526       IS=1
32527       IRH=0
32528       IST=1
32529       NSTAB=23
32530       IRE=NURE(N,1)
32531       IF(ITTA.GT.1) IRE=NURE(N,2)
32532 C
32533 C-----------------------------
32534 C*** IE,AMT,ECM,SI DETERMINATION
32535 C----------------------------
32536       CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
32537       IANTH=-1
32538 **sr
32539 C     IF (AMH(1).NE.0.93828D0) IANTH=1
32540       IF (AMH(1).NE.0.9383D0) IANTH=1
32541 **
32542       IF (IANTH.GE.0) SI=1.0D0
32543       ECMMH=ECM
32544 C
32545 C-----------------------------
32546 C    ENERGY INDEX
32547 C  IRE CHARACTERIZES THE REACTION
32548 C  IE IS THE ENERGY INDEX
32549 C----------------------------
32550       IF (SI.LT.1.D-6) THEN
32551 C        WRITE(LOUT,*) ' jump 2'
32552          GO TO 280
32553       ENDIF
32554       IF (N.LE.NSTAB)                                           GO TO 60
32555       RUNTES=RUNTES+1.0D0
32556       IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
32557  1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
32558       IF(IBARH(N).EQ.1) N=8
32559       IF(IBARH(N).EQ.-1)  N=9
32560    60 CONTINUE
32561       IMACH=IMACH+1
32562 **sr 19.2.97: loop for direct channel suppression
32563 C     IF (IMACH.GT.10) THEN
32564       IF (IMACH.GT.1000) THEN
32565 **
32566 C        WRITE(LOUT,*) ' jump 3'
32567          GO TO 280
32568       ENDIF
32569       ECM =ECMMH
32570       AMN2=AMN**2
32571       AMT2=AMT**2
32572       ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM    )
32573       IF(ECMN.LE.AMN) ECMN=AMN
32574       PCMN=SQRT(ECMN**2-AMN2)
32575       GAM=(ELAB+AMT)/ECM
32576       BGAM=PLAB/ECM
32577       IF (IANTH.GE.0) ECM=2.1D0
32578 C
32579 C-----------------------------
32580 C*** RANDOM CHOICE OF REACTION CHANNEL
32581 C----------------------------
32582       IST=0
32583       VV=DT_RNDM(AMN2)
32584       VV=VV-1.D-17
32585 C
32586 C-----------------------------
32587 C***  PLACE REDUCED VERSION
32588 C----------------------------
32589       IIEI=IEII(IRE)
32590       IDWK=IEII(IRE+1)-IIEI
32591       IIWK=IRII(IRE)
32592       IIKI=IKII(IRE)
32593 C
32594 C-----------------------------
32595 C***  SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
32596 C----------------------------
32597       HECM=ECM
32598       HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
32599       IF (HUMO.LT.ECM) ECM=HUMO
32600 C
32601 C-----------------------------
32602 C*** INTERPOLATION PREPARATION
32603 C----------------------------
32604       ECMO=UMO(IE)
32605       ECM1=UMO(IE-1)
32606       DECM=ECMO-ECM1
32607       DEC=ECMO-ECM
32608 C
32609 C-----------------------------
32610 C*** RANDOM LOOP
32611 C----------------------------
32612       IK=0
32613       WKK=0.0D0
32614       WICOR=0.0D0
32615    70 IK=IK+1
32616       IWK=IIWK+(IK-1)*IDWK+IE-IIEI
32617       WOK=WK(IWK)
32618       WDK=WOK-WK(IWK-1)
32619 C
32620 C-----------------------------
32621 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
32622 C    GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
32623 C    CONTRIBUTE
32624 C----------------------------
32625       IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
32626       WICO=WOK*1.23459876D0+WDK*1.735218469D0
32627       IF (WICO.EQ.WICOR)                                        GO TO 70
32628       IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
32629       WICOR=WICO
32630 C
32631 C-----------------------------
32632 C*** INTERPOLATION IN CHANNEL WEIGHTS
32633 C----------------------------
32634       EKLIM=-THRESH(IIKI+IK)
32635       IELIM=IDT_IEFUND(EKLIM,IRE)
32636       DELIM=UMO(IELIM)+EKLIM
32637      *+1.D-16
32638       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
32639       IF (DELIM*DELIM-DETE*DETE) 90,90,80
32640    80 DECC=DELIM
32641                                                                GO TO 100
32642    90 DECC=DECM
32643   100 CONTINUE
32644       WKK=WOK-WDK*DEC/(DECC+1.D-9)
32645 C
32646 C-----------------------------
32647 C*** RANDOM CHOICE
32648 C----------------------------
32649 C
32650       IF (VV.GT.WKK)                                            GO TO 70
32651 C
32652 C***IK IS THE REACTION CHANNEL
32653 C----------------------------
32654       INRK=IKII(IRE)+IK
32655       ECM=HECM
32656       I1001 =0
32657 C
32658   110 CONTINUE
32659       IT1=NRK(1,INRK)
32660       AM1=DT_DAMG(IT1)
32661       IT2=NRK(2,INRK)
32662       AM2=DT_DAMG(IT2)
32663       AMS=AM1+AM2
32664       I1001=I1001+1
32665       IF (I1001.GT.50)                                          GO TO 60
32666 C
32667       IF (IT2*AMS.GT.IT2*ECM)                                  GO TO 110
32668       IT11=IT1
32669       IT22=IT2
32670       IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
32671       AM11=AM1
32672       AM22=AM2
32673       IF (IT2.GT.0)                                            GO TO 120
32674 **sr 19.2.97: supress direct channel for pp-collisions
32675       IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
32676          RR = DT_RNDM(AM11)
32677          IF (RR.LE.0.75D0) GOTO 60
32678       ENDIF
32679 **
32680 C
32681 C-----------------------------
32682 C  INCLUSION OF DIRECT RESONANCES
32683 C  RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE  IT1
32684 C------------------------
32685       KZ1=K1H(IT1)
32686       IST=IST+1
32687       IECO=0
32688       ECO=ECM
32689       GAM=(ELAB+AMT)/ECO
32690       BGAM=PLAB/ECO
32691       CXS(1)=CX
32692       CYS(1)=CY
32693       CZS(1)=CZ
32694                                                                GO TO 170
32695   120 CONTINUE
32696       WW=DT_RNDM(ECO)
32697       IF(WW.LT. 0.5D0)                                         GO TO 130
32698       IT1=IT22
32699       IT2=IT11
32700       AM1=AM22
32701       AM2=AM11
32702   130 CONTINUE
32703 C
32704 C-----------------------------
32705 C   THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
32706       IBN=IBARH(N)
32707       IB1=IBARH(IT1)
32708       IT11=IT1
32709       IT22=IT2
32710       AM11=AM1
32711       AM22=AM2
32712       IF(IB1.EQ.IBN)                                           GO TO 140
32713       IT1=IT22
32714       IT2=IT11
32715       AM1=AM22
32716       AM2=AM11
32717   140 CONTINUE
32718 C-----------------------------
32719 C***IT1,IT2 ARE THE CREATED PARTICLES
32720 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
32721 C------------------------
32722       CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
32723      *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
32724       IST=IST+1
32725       ITS(IST)=IT1
32726       AMM(IST)=AM1
32727 C
32728 C-----------------------------
32729 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
32730 C----------------------------
32731       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
32732      &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32733       IST=IST+1
32734       ITS(IST)=IT2
32735       AMM(IST)=AM2
32736       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
32737      *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32738   150 CONTINUE
32739 C
32740 C-----------------------------
32741 C***TEST   STABLE OR UNSTABLE
32742 C----------------------------
32743       IF(ITS(IST).GT.NSTAB)                                    GO TO 160
32744       IRH=IRH+1
32745 C
32746 C-----------------------------
32747 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
32748 C----------------------------
32749 C*    IF (REDU.LT.0.D0) GO TO 1009
32750       ITRH(IRH)=ITS(IST)
32751       PLRH(IRH)=PLS(IST)
32752       CXRH(IRH)=CXS(IST)
32753       CYRH(IRH)=CYS(IST)
32754       CZRH(IRH)=CZS(IST)
32755       ELRH(IRH)=ELS(IST)
32756       IST=IST-1
32757       IF(IST.GE.1)                                             GO TO 150
32758                                                                GO TO 260
32759   160 CONTINUE
32760 C
32761 C  RANDOM CHOICE OF DECAY CHANNELS
32762 C----------------------------
32763 C
32764       IT=ITS(IST)
32765       ECO=AMM(IST)
32766       GAM=ELS(IST)/ECO
32767       BGAM=PLS(IST)/ECO
32768       IECO=0
32769       KZ1=K1H(IT)
32770   170 CONTINUE
32771       IECO=IECO+1
32772       VV=DT_RNDM(GAM)
32773       VV=VV-1.D-17
32774       IIK=KZ1-1
32775   180 IIK=IIK+1
32776       IF (VV.GT.WTI(IIK))                                      GO TO 180
32777 C
32778 C  IIK IS THE DECAY CHANNEL
32779 C----------------------------
32780       IT1=NZKI(IIK,1)
32781       I310=0
32782   190 CONTINUE
32783       I310=I310+1
32784       AM1=DT_DAMG(IT1)
32785       IT2=NZKI(IIK,2)
32786       AM2=DT_DAMG(IT2)
32787       IF (IT2-1.LT.0)                                          GO TO 240
32788       IT3=NZKI(IIK,3)
32789       AM3=DT_DAMG(IT3)
32790       AMS=AM1+AM2+AM3
32791 C
32792 C  IF  IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
32793 C----------------------------
32794       IF (IECO.LE.10)                                          GO TO 200
32795       IATMPT=IATMPT+1
32796       IF(IATMPT.GT.3) THEN
32797 C        WRITE(LOUT,*) ' jump 4'
32798          GO TO 280
32799       ENDIF
32800                                                                 GO TO 40
32801   200 CONTINUE
32802       IF (I310.GT.50)                                          GO TO 170
32803       IF (AMS.GT.ECO)                                          GO TO 190
32804 C
32805 C  FOR THE DECAY CHANNEL
32806 C  IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM  IT
32807 C----------------------------
32808       IF (REDU.LT.0.D0)                                        GO TO 30
32809       ITWTHC=0
32810       REDU=2.0D0
32811       IF(IT3.EQ.0)                                             GO TO 220
32812   210 CONTINUE
32813       ITWTH=1
32814       CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
32815      *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
32816                                                                GO TO 230
32817   220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
32818      &COD2,COF2,SIF2,AM1,AM2)
32819       ITWTH=-1
32820       IT3=0
32821   230 CONTINUE
32822       ITWTHC=ITWTHC+1
32823       IF (REDU.GT.0.D0)                                        GO TO 240
32824       REDU=2.0D0
32825       IF (ITWTHC.GT.100)                                        GO TO 30
32826       IF (ITWTH) 220,220,210
32827   240 CONTINUE
32828       ITS(IST  )=IT1
32829       IF (IT2-1.LT.0)                                          GO TO 250
32830       ITS(IST+1)  =IT2
32831       ITS(IST+2)=IT3
32832       RX=CXS(IST)
32833       RY=CYS(IST)
32834       RZ=CZS(IST)
32835       AMM(IST)=AM1
32836       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
32837      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32838       IST=IST+1
32839       AMM(IST)=AM2
32840       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
32841      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32842       IF (IT3.LE.0)                                            GO TO 250
32843       IST=IST+1
32844       AMM(IST)=AM3
32845       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
32846      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32847   250 CONTINUE
32848                                                                GO TO 150
32849   260 CONTINUE
32850   270 CONTINUE
32851       RETURN
32852   280 CONTINUE
32853 C
32854 C----------------------------
32855 C
32856 C   ZERO CROSS SECTION CASE
32857 C----------------------------
32858 C
32859       IRH=1
32860       ITRH(1)=N
32861       CXRH(1)=CX
32862       CYRH(1)=CY
32863       CZRH(1)=CZ
32864       ELRH(1)=ELAB
32865       PLRH(1)=PLAB
32866       RETURN
32867       END
32868
32869 *$ CREATE DT_RUNTT.FOR
32870 *COPY DT_RUNTT
32871 *
32872 *===runtt==============================================================*
32873 *
32874       BLOCK DATA DT_RUNTT
32875
32876       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32877       SAVE
32878
32879       COMMON /HNDRUN/ RUNTES,EFTES
32880
32881       DATA RUNTES,EFTES /100.D0,100.D0/
32882
32883       END
32884
32885 *$ CREATE DT_NONAME.FOR
32886 *COPY DT_NONAME
32887 *
32888 *===noname=============================================================*
32889 *
32890       BLOCK DATA DT_NONAME
32891
32892       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32893       SAVE
32894
32895 * slope parameters for HADRIN interactions
32896       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
32897
32898       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32899
32900 C     DATAS     DATAS    DATAS      DATAS     DATAS
32901 C******          *********
32902       DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
32903      &           207, 224, 241, 252, 268 /
32904       DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
32905      &           220, 241, 262, 279, 296 /
32906       DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
32907      &           3364, 3507, 4011, 4368, 4725, 4912, 5184/
32908
32909 C
32910 C     MASSES FOR THE SLOPE B(M) IN GEV
32911 C     SLOPE B(M) FOR AN MESONIC SYSTEM
32912 C     SLOPE B(M) FOR A BARYONIC SYSTEM
32913
32914 *
32915       DATA SM,BBM,BBB/  0.8D0, 0.85D0,  0.9D0, 0.95D0, 1.D0,
32916      &     1.05D0,  1.1D0, 1.15D0,  1.2D0, 1.25D0,
32917      &      1.3D0,  1.35D0, 1.4D0,  1.45D0,  1.5D0,
32918      &     1.55D0,  1.6D0,  1.65D0, 1.7D0,   1.75D0,
32919      &      1.8D0,  1.85D0, 1.9D0,  1.95D0,  2.D0,
32920      &     15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
32921      &    12.35D0, 11.7D0, 10.85D0, 10.D0,  9.15D0,
32922      &      8.3D0,  7.8D0,  7.3D0,  7.25D0,  7.2D0,
32923      &     6.95D0,  6.7D0,  6.6D0,  6.5D0,   6.3D0,
32924      &      6.1D0,  5.85D0, 5.6D0,  5.35D0,  5.1D0,
32925      &      15.D0,   15.D0, 15.D0,  15.D0,   15.D0, 15.D0, 15.D0,
32926      &     14.2D0,  13.4D0, 12.6D0,
32927      &     11.8D0, 11.2D0, 10.6D0,  9.8D0,    9.D0,
32928      &     8.25D0,  7.5D0, 6.25D0,  5.D0,    4.5D0, 5*4.D0 /
32929 *
32930       END
32931
32932 *$ CREATE DT_DAMG.FOR
32933 *COPY DT_DAMG
32934 *
32935 *===damg===============================================================*
32936 *
32937       DOUBLE PRECISION FUNCTION DT_DAMG(IT)
32938
32939       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32940       SAVE
32941
32942 * particle properties (BAMJET index convention),
32943 * (dublicate of DTPART for HADRIN)
32944       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32945      &                K1H(110),K2H(110)
32946
32947       DIMENSION GASUNI(14)
32948       DATA GASUNI/
32949      *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
32950      *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
32951       DATA GAUNO/2.352D0/
32952       DATA GAUNON/2.4D0/
32953       DATA IO/14/
32954       DATA NSTAB/23/
32955
32956       I=1
32957       IF (IT.LE.0)                                              GO TO 30
32958       IF (IT.LE.NSTAB)                                          GO TO 20
32959       DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
32960       VV=DT_RNDM(DGAUNI)
32961       VV=VV*2.0D0-1.0D0+1.D-16
32962    10 CONTINUE
32963       VO=GASUNI(I)
32964       I=I+1
32965       V1=GASUNI(I)
32966       IF (VV.GT.V1)                                             GO TO 10
32967       UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
32968      &      (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
32969       DAM=GAH(IT)*UNIGA/GAUNO
32970       AAM=AMH(IT)+DAM
32971       DT_DAMG=AAM
32972       RETURN
32973    20 CONTINUE
32974       DT_DAMG=AMH(IT)
32975       RETURN
32976    30 CONTINUE
32977       DT_DAMG=0.0D0
32978       RETURN
32979       END
32980
32981 *$ CREATE DT_DCALUM.FOR
32982 *COPY DT_DCALUM
32983 *
32984 *===dcalum=============================================================*
32985 *
32986       SUBROUTINE DT_DCALUM(N,ITTA)
32987
32988       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32989       SAVE
32990
32991 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
32992
32993 * particle properties (BAMJET index convention),
32994 * (dublicate of DTPART for HADRIN)
32995       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32996      &                K1H(110),K2H(110)
32997
32998       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32999
33000       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33001
33002       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33003      &                NRK(2,268),NURE(30,2)
33004
33005       IRE=NURE(N,ITTA/8+1)
33006       IEO=IEII(IRE)+1
33007       IEE=IEII(IRE +1)
33008       AM1=AMH(N   )
33009       AM12=AM1**2
33010       AM2=AMH(ITTA)
33011       AM22=AM2**2
33012       DO 10 IE=IEO,IEE
33013         PLAB2=PLABF(IE)**2
33014         ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
33015         UMO(IE)=ELAB
33016    10 CONTINUE
33017       IKO=IKII(IRE)+1
33018       IKE=IKII(IRE +1)
33019       UMOO=UMO(IEO)
33020       DO 30 IK=IKO,IKE
33021         IF(NRK(2,IK).GT.0)                                      GO TO 30
33022         IKI=NRK(1,IK)
33023         AMSS=5.0D0
33024         K11=K1H(IKI)
33025         K22=K2H(IKI)
33026         DO 20 IK1=K11,K22
33027           IN=NZKI(IK1,1)
33028           AMS=AMH(IN)
33029           IN=NZKI(IK1,2)
33030           IF(IN.GT.0)AMS=AMS+AMH(IN)
33031           IN=NZKI(IK1,3)
33032           IF(IN.GT.0) AMS=AMS+AMH(IN)
33033           IF (AMS.LT.AMSS) AMSS=AMS
33034    20   CONTINUE
33035         IF(UMOO.LT.AMSS) UMOO=AMSS
33036         THRESH(IK)=UMOO
33037    30 CONTINUE
33038       RETURN
33039       END
33040
33041 *$ CREATE DT_DCHANH.FOR
33042 *COPY DT_DCHANH
33043 *
33044 *===dchanh=============================================================*
33045 *
33046       SUBROUTINE DT_DCHANH
33047
33048       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33049       SAVE
33050
33051       PARAMETER ( LINP = 10 ,
33052      &            LOUT = 6 ,
33053      &            LDAT = 9 )
33054
33055 * particle properties (BAMJET index convention),
33056 * (dublicate of DTPART for HADRIN)
33057       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33058      &                K1H(110),K2H(110)
33059
33060       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33061
33062       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33063
33064       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33065      &                NRK(2,268),NURE(30,2)
33066
33067       DIMENSION HWT(460),HWK(40),SI(5184)
33068       EQUIVALENCE (WK(1),SI(1))
33069 C--------------------
33070 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
33071 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
33072 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
33073 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
33074 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
33075 C--------------------------
33076       IREG=16
33077       DO 90 IRE=1,IREG
33078         IWKO=IRII(IRE)
33079         IEE=IEII(IRE+1)-IEII(IRE)
33080         IKE=IKII(IRE+1)-IKII(IRE)
33081         IEO=IEII(IRE)+1
33082         IIKA=IKII(IRE)
33083 *   modifications to suppress elestic scattering  24/07/91
33084         DO 80 IE=1,IEE
33085           SIS=1.D-14
33086           SINORC=0.0D0
33087           DO 10 IK=1,IKE
33088             IWK=IWKO+IEE*(IK-1)+IE
33089             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33090             SIS=SIS+SI(IWK)*SINORC
33091    10     CONTINUE
33092           SIIN(IEO+IE-1)=SIS
33093           SIO=0.D0
33094           IF (SIS.GE.1.D-12)                                    GO TO 20
33095           SIS=1.D0
33096           SIO=1.D0
33097    20     CONTINUE
33098           SINORC=0.0D0
33099           DO 30 IK=1,IKE
33100             IWK=IWKO+IEE*(IK-1)+IE
33101             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33102             SIO=SIO+SI(IWK)*SINORC/SIS
33103             HWK(IK)=SIO
33104    30     CONTINUE
33105           DO 40 IK=1,IKE
33106             IWK=IWKO+IEE*(IK-1)+IE
33107    40     WK(IWK)=HWK(IK)
33108           IIKI=IKII(IRE)
33109           DO 70 IK=1,IKE
33110             AM111=0.D0
33111             INRK1=NRK(1,IIKI+IK)
33112             IF (INRK1.GT.0) AM111=AMH(INRK1)
33113             AM222=0.D0
33114             INRK2=NRK(2,IIKI+IK)
33115             IF (INRK2.GT.0) AM222=AMH(INRK2)
33116             THRESH(IIKI+IK)=AM111 +AM222
33117             IF (INRK2-1.GE.0)                                   GO TO 60
33118             INRKK=K1H(INRK1)
33119             AMSS=5.D0
33120             INRKO=K2H(INRK1)
33121             DO 50 INRK1=INRKK,INRKO
33122               INZK1=NZKI(INRK1,1)
33123               INZK2=NZKI(INRK1,2)
33124               INZK3=NZKI(INRK1,3)
33125               IF (INZK1.LE.0.OR.INZK1.GT.110)                   GO TO 50
33126               IF (INZK2.LE.0.OR.INZK2.GT.110)                   GO TO 50
33127               IF (INZK3.LE.0.OR.INZK3.GT.110)                   GO TO 50
33128 C     WRITE (6,310)INRK1,INZK1,INZK2,INZK3
33129  1000 FORMAT (4I10)
33130               AMS=AMH(INZK1)+AMH(INZK2)
33131               IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
33132               IF (AMSS.GT.AMS) AMSS=AMS
33133    50       CONTINUE
33134             AMS=AMSS
33135             IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
33136             THRESH(IIKI+IK)=AMS
33137    60       CONTINUE
33138    70     CONTINUE
33139    80   CONTINUE
33140    90 CONTINUE
33141       DO 100 J=1,460
33142   100 HWT(J)=0.D0
33143       DO 120 I=1,110
33144         IK1=K1H(I)
33145         IK2=K2H(I)
33146         HV=0.D0
33147         IF (IK2.GT.460)IK2=460
33148         IF (IK1.LE.0)IK1=1
33149         DO 110 J=IK1,IK2
33150           HV=HV+WTI(J)
33151           HWT(J)=HV
33152           JI=J
33153   110   CONTINUE
33154         IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
33155  1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
33156   120 CONTINUE
33157       DO 130 J=1,460
33158   130 WTI(J)=HWT(J)
33159       RETURN
33160       END
33161
33162 *$ CREATE DT_DHADDE.FOR
33163 *COPY DT_DHADDE
33164 *
33165 *===dhadde=============================================================*
33166 *
33167       SUBROUTINE DT_DHADDE
33168
33169       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33170       SAVE
33171
33172 * particle properties (BAMJET index convention)
33173       CHARACTER*8  ANAME
33174       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33175      &                IICH(210),IIBAR(210),K1(210),K2(210)
33176
33177 * HADRIN: decay channel information
33178       PARAMETER (IDMAX9=602)
33179       CHARACTER*8 ZKNAME
33180       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
33181
33182 * particle properties (BAMJET index convention),
33183 * (dublicate of DTPART for HADRIN)
33184       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33185      &                K1H(110),K2H(110)
33186
33187       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33188
33189 * decay channel information for HADRIN
33190       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33191      &                K1Z(16),K2Z(16),WTZ(153),II22,
33192      &                NZK1(153),NZK2(153),NZK3(153)
33193
33194       DATA IRETUR/0/
33195
33196       IRETUR=IRETUR+1
33197       AMH(31)=0.48D0
33198       IF (IRETUR.GT.1) RETURN
33199       DO 10 I=1,94
33200         AMH(I)   = AAM(I)
33201         GAH(I)   = GA(I)
33202         TAUH(I)  = TAU(I)
33203         ICHH(I)  = IICH(I)
33204         IBARH(I) = IIBAR(I)
33205         K1H(I)   = K1(I)
33206         K2H(I)   = K2(I)
33207    10 CONTINUE
33208 **sr
33209 C     AMH(1)=0.93828D0
33210       AMH(1)=0.9383D0
33211 **
33212       AMH(2)=AMH(1)
33213       DO 20 I=26,30
33214         K1H(I)=452
33215         K2H(I)=452
33216    20 CONTINUE
33217       DO 30 I=1,307
33218         WTI(I)    = WT(I)
33219         NZKI(I,1) = NZK(I,1)
33220         NZKI(I,2) = NZK(I,2)
33221         NZKI(I,3) = NZK(I,3)
33222    30 CONTINUE
33223       DO 40 I=1,16
33224         L=I+94
33225         AMH(L)=AMZ(I)
33226         GAH( L)=GAZ(I)
33227         TAUH( L)=TAUZ(I)
33228         ICHH( L)=ICHZ(I)
33229         IBARH( L)=IBARZ(I)
33230         K1H( L)=K1Z(I)
33231         K2H( L)=K2Z(I)
33232    40 CONTINUE
33233       DO 50 I=1,153
33234         L=I+307
33235         WTI(L)    = WTZ(I)
33236         NZKI(L,3) = NZK3(I)
33237         NZKI(L,2) = NZK2(I)
33238         NZKI(L,1) = NZK1(I)
33239    50 CONTINUE
33240       RETURN
33241       END
33242
33243 *$ CREATE IDT_IEFUND.FOR
33244 *COPY IDT_IEFUND
33245 *
33246 *===iefund=============================================================*
33247 *
33248       INTEGER FUNCTION IDT_IEFUND(PL,IRE)
33249
33250       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33251       SAVE
33252
33253 C*****IEFUN CALCULATES A MOMENTUM INDEX
33254
33255       PARAMETER ( LINP = 10 ,
33256      &            LOUT = 6 ,
33257      &            LDAT = 9 )
33258
33259       COMMON /HNDRUN/ RUNTES,EFTES
33260
33261       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33262
33263       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33264      &                NRK(2,268),NURE(30,2)
33265
33266       IPLA=IEII(IRE)+1
33267      *+1
33268       IPLE=IEII(IRE+1)
33269       IF (PL.LT.0.)                                             GO TO 30
33270       DO 10 I=IPLA,IPLE
33271         J=I-IPLA+1
33272         IF (PL.LE.PLABF(I))                                     GO TO 60
33273    10 CONTINUE
33274       I=IPLE
33275       IF ( EFTES.GT.40.D0)                                      GO TO 20
33276       EFTES=EFTES+1.0D0
33277       WRITE(LOUT,1000)PL,J
33278    20 CONTINUE
33279                                                                 GO TO 70
33280    30 CONTINUE
33281       DO 40 I=IPLA,IPLE
33282         J=I-IPLA+1
33283         IF (-PL.LE.UMO(I))                                      GO TO 60
33284    40 CONTINUE
33285       I=IPLE
33286       IF ( EFTES.GT.40.D0)                                      GO TO 50
33287       EFTES=EFTES+1.0D0
33288       WRITE(LOUT,1000)PL,I
33289    50 CONTINUE
33290    60 CONTINUE
33291    70 CONTINUE
33292       IDT_IEFUND=I
33293       RETURN
33294  1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
33295      +7H IEFUN=,I5)
33296       END
33297
33298 *$ CREATE DT_DSIGIN.FOR
33299 *COPY DT_DSIGIN
33300 *
33301 *===dsigin=============================================================*
33302 *
33303       SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
33304
33305       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33306       SAVE
33307
33308 * particle properties (BAMJET index convention),
33309 * (dublicate of DTPART for HADRIN)
33310       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33311      &                K1H(110),K2H(110)
33312
33313       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33314
33315       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33316      &                NRK(2,268),NURE(30,2)
33317
33318       IE=IDT_IEFUND(PLAB,IRE)
33319       IF (IE.LE.IEII(IRE)) IE=IE+1
33320       AMT=AMH(ITAR)
33321       AMN=AMH(N)
33322       AMN2=AMN*AMN
33323       AMT2=AMT*AMT
33324       ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
33325 C*** INTERPOLATION PREPARATION
33326       ECMO=UMO(IE)
33327       ECM1=UMO(IE-1)
33328       DECM=ECMO-ECM1
33329       DEC=ECMO-ECM
33330       IIKI=IKII(IRE)+1
33331       EKLIM=-THRESH(IIKI)
33332       WOK=SIIN(IE)
33333       WDK=WOK-SIIN(IE-1)
33334       IF (ECM.GT.ECMO) WDK=0.0D0
33335 C*** INTERPOLATION IN CHANNEL WEIGHTS
33336       IELIM=IDT_IEFUND(EKLIM,IRE)
33337       DELIM=UMO(IELIM)+EKLIM
33338      *+1.D-16
33339       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
33340       IF (DELIM*DELIM-DETE*DETE) 20,20,10
33341    10 DECC=DELIM
33342                                                                 GO TO 30
33343    20 DECC=DECM
33344    30 CONTINUE
33345       WKK=WOK-WDK*DEC/(DECC+1.D-9)
33346       IF (WKK.LT.0.0D0) WKK=0.0D0
33347       SI=WKK+1.D-12
33348       IF (-EKLIM.GT.ECM) SI=1.D-14
33349       RETURN
33350       END
33351
33352 *$ CREATE DT_DTCHOI.FOR
33353 *COPY DT_DTCHOI
33354 *
33355 *===dtchoi=============================================================*
33356 *
33357       SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
33358
33359       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33360       SAVE
33361
33362 C     ****************************
33363 C     TCHOIC CALCULATES A RANDOM VALUE
33364 C     FOR THE FOUR-MOMENTUM-TRANSFER T
33365 C     ****************************
33366
33367 * particle properties (BAMJET index convention),
33368 * (dublicate of DTPART for HADRIN)
33369       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33370      &                K1H(110),K2H(110)
33371
33372 * slope parameters for HADRIN interactions
33373       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
33374
33375       AMA=AM1
33376       AMB=AM2
33377       IF (I.GT.30.AND.II.GT.30)                                 GO TO 20
33378       III=II
33379       AM3=AM2
33380       IF (I.LE.30)                                              GO TO 10
33381       III=I
33382       AM3=AM1
33383    10 CONTINUE
33384                                                                 GO TO 30
33385    20 CONTINUE
33386       III=II
33387       AM3=AM2
33388       IF (AMA.LE.AMB)                                           GO TO 30
33389       III=I
33390       AM3=AM1
33391    30 CONTINUE
33392       IB=IBARH(III)
33393       AMA=AM3
33394       K=INT((AMA-0.75D0)/0.05D0)
33395       IF (K-2.LT.0) K=1
33396       IF (K-26.GE.0) K=25
33397       IF (IB)50,40,50
33398    40 BM=BBM(K)
33399                                                                 GO TO 60
33400    50 BM=BBB(K)
33401    60 CONTINUE
33402 C     NORMALIZATION
33403       TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1  **2
33404       TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1  **2
33405       VB=DT_RNDM(TMIN)
33406 **sr test
33407 C     IF (VB.LT.0.2D0) BM=BM*0.1
33408 C    **0.5
33409       BM = BM*5.05D0
33410 **
33411       TMI=BM*TMIN
33412       TMA=BM*TMAX
33413       ETMA=0.D0
33414       IF (ABS(TMA).GT.120.D0)                                   GO TO 70
33415       ETMA=EXP(TMA)
33416    70 CONTINUE
33417       AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
33418 C*** RANDOM CHOICE OF THE T - VALUE
33419       R=DT_RNDM(TMI)
33420       T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
33421       RETURN
33422       END
33423
33424 *$ CREATE DT_DTWOPA.FOR
33425 *COPY DT_DTWOPA
33426 *
33427 *===dtwopa=============================================================*
33428 *
33429       SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
33430      &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
33431
33432       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33433       SAVE
33434
33435 C     ******************************************************
33436 C     QUASI TWO PARTICLE PRODUCTION
33437 C     TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
33438 C     FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
33439 C     IN THE CM - SYSTEM
33440 C     COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
33441 C     SPHERICAL COORDINATES
33442 C     ******************************************************
33443
33444 * particle properties (BAMJET index convention),
33445 * (dublicate of DTPART for HADRIN)
33446       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33447      &                K1H(110),K2H(110)
33448
33449       AMA=AM1
33450       AMB=AM2
33451       AMA2=AMA*AMA
33452       E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
33453       E2=UMOO - E1
33454       IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
33455       AMTE=(E1-AMA)*(E1+AMA)
33456       AMTE=AMTE+1.D-18
33457       P1=SQRT(AMTE)
33458       P2=P1
33459 C     / P2 / = / P1 /  BUT OPPOSITE DIRECTIONS
33460 C     DETERMINATION  OF  THE ANGLES
33461 C     COS(THETA1)=COD1      COS(THETA2)=COD2
33462 C     SIN(PHI1)=SIF1        SIN(PHI2)=SIF2
33463 C     COS(PHI1)=COF1        COS(PHI2)=COF2
33464 C     PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
33465       CALL DT_DSFECF(COF1,SIF1)
33466       COF2=-COF1
33467       SIF2=-SIF1
33468 C     CALCULATION OF THETA1
33469       CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
33470       COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
33471       IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
33472       COD2=-COD1
33473       RETURN
33474       END
33475
33476 *$ CREATE DT_ZK.FOR
33477 *COPY DT_ZK
33478 *
33479 *===zk=================================================================*
33480 *
33481       BLOCK DATA DT_ZK
33482
33483       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33484       SAVE
33485
33486 * decay channel information for HADRIN
33487       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33488      &                K1Z(16),K2Z(16),WTZ(153),II22,
33489      &                NZK1(153),NZK2(153),NZK3(153)
33490
33491 * decay channel information for HADRIN
33492       CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
33493       COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
33494
33495 *     Particle masses in GeV                                           *
33496       DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
33497      &          2*1.7D0, 3*0.D0/
33498 *     Resonance width Gamma in GeV                                     *
33499       DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
33500 *     Mean life time in seconds                                        *
33501       DATA TAUZ / 16*0.D0 /
33502 *     Charge of particles and resonances                               *
33503       DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
33504 *     Baryonic charge                                                  *
33505       DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
33506 *     First number of decay channels used for resonances               *
33507 *     and decaying particles                                           *
33508       DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
33509      &          3*460/
33510 *     Last number of decay channels used for resonances                *
33511 *     and decaying particles                                           *
33512       DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
33513      &          3*460/
33514 *     Weight of decay channel                                          *
33515       DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
33516      & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
33517      & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
33518      & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
33519      & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
33520      & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
33521      & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
33522      & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
33523      & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
33524      & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
33525      & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
33526      & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
33527      & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
33528      & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
33529      & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
33530      & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
33531      & .05D0, .65D0, 9*1.D0 /
33532 *     Particle numbers in decay channel                                *
33533       DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
33534      & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
33535      & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
33536      & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
33537      & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
33538      & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
33539      & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
33540      & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
33541       DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
33542      & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
33543      & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
33544      & 4*33, 32, 3*35,  2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
33545      & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
33546      & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
33547      & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
33548      & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
33549      & 1, 8, 1, 8, 1, 9*0 /
33550       DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
33551      & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
33552      & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
33553      & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
33554      & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
33555      & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
33556 *     Particle  names                                                  *
33557       DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS  ',' PAP  ',' PAN  ',
33558      & 'APN', 'DEO   ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
33559      & 3*'BLANK' /
33560 *     Name of decay channel                                            *
33561       DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
33562      & 'ANNPI0','APPPI0','ANPPI-'/
33563       DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K-  ','K0AK0 ',
33564      & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET  ','&0R0  ','P-R+  ',
33565      & 'P+R-  ','POOM  ',' ETET ','ETSP0 ','R0ET  ',' R0R0 ','R+R-  ',
33566      & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
33567      & 'P+R-R0','R0OM  ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
33568      & 'P+R-OM','OMOM  ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
33569      & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
33570      & 'OMOMOM',
33571      & ' P+PO ','P+POPO','P+P+P-','P+ET  ','P0R+  ','P+R0  ','ETSP+ ',
33572      & 'R+ET  ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
33573      & 'P+R-R+','R+OM  ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
33574      & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
33575      & 'P-PO  ','P-POPO','P-P-P+','P-ET  ','POR-  ','P-R0  ','ETSP- ',
33576      & 'R-ET  ','R-R0  ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
33577       DATA ZKNAM6/'P+R-R-','R-OM  ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
33578      & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
33579      & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO  ','LPI+  ',
33580      & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
33581      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
33582      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
33583      & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
33584      & 9*'BLANK'/
33585 *=                                               end*block.zk      *
33586       END
33587
33588 *$ CREATE DT_BLKD43.FOR
33589 *COPY DT_BLKD43
33590 *
33591 *===blkd43=============================================================*
33592 *
33593       BLOCK DATA DT_BLKD43
33594
33595       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33596       SAVE
33597
33598 *
33599 *=== reac =============================================================*
33600 *
33601 *----------------------------------------------------------------------*
33602 *                                                                      *
33603 *     Created on 10 december 1991  by    Alfredo Ferrari & Paola Sala  *
33604 *                                                   Infn - Milan       *
33605 *                                                                      *
33606 *     Last change on 10-dec-91     by    Alfredo Ferrari               *
33607 *                                                                      *
33608 *     This is the original common reac of Hadrin                       *
33609 *                                                                      *
33610 *----------------------------------------------------------------------*
33611 *
33612
33613       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33614      &                NRK(2,268),NURE(30,2)
33615
33616       DIMENSION
33617      & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
33618      & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
33619      & SPIKP1(315), SPIKPU(278), SPIKPV(372),
33620      & SPIKPW(278), SPIKPX(372), SPIKP4(315),
33621      & SPIKP5(187), SPIKP6(289),
33622      & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
33623      & SPIKP9(143), SPIKP0(169), SPKPV(143),
33624      & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
33625      & SANPEL(84) , SPIKPF(273),
33626      & SPKP15(187), SPKP16(272),
33627      & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
33628      & NURELN(60)
33629 *
33630        DIMENSION NRKLIN(532)
33631        EQUIVALENCE (NRK(1,1), NRKLIN(1))
33632        EQUIVALENCE (   UMO(  1),  UMOPI(1)), (   UMO( 93),  UMOKC(1))
33633        EQUIVALENCE (   UMO(161),   UMOP(1)), (   UMO(200),   UMON(1))
33634        EQUIVALENCE (   UMO(263),  UMOK0(1))
33635        EQUIVALENCE ( PLABF(  1),  PLAPI(1)), ( PLABF( 93),  PLAKC(1))
33636        EQUIVALENCE ( PLABF(161),   PLAP(1)), ( PLABF(200),   PLAN(1))
33637        EQUIVALENCE ( PLABF(263),  PLAK0(1))
33638        EQUIVALENCE (   WK(   1), SPIKP1(1)), (   WK( 316), SPIKPU(1))
33639        EQUIVALENCE (   WK( 594), SPIKPV(1)), (   WK( 966), SPIKPW(1))
33640        EQUIVALENCE (   WK(1244), SPIKPX(1)), (   WK(1616), SPIKP4(1))
33641        EQUIVALENCE (   WK(1931), SPIKP5(1)), (   WK(2118), SPIKP6(1))
33642        EQUIVALENCE (   WK(2407), SKMPEL(1)), (   WK(2509), SPIKP7(1))
33643        EQUIVALENCE (   WK(2798), SKMNEL(1)), (   WK(2866), SPIKP8(1))
33644        EQUIVALENCE (   WK(3053), SPIKP9(1)), (   WK(3196), SPIKP0(1))
33645        EQUIVALENCE (   WK(3365),  SPKPV(1)), (   WK(3508), SAPPEL(1))
33646        EQUIVALENCE (   WK(3613), SPIKPE(1)), (   WK(4012), SAPNEL(1))
33647        EQUIVALENCE (   WK(4096), SPIKPZ(1)), (   WK(4369), SANPEL(1))
33648        EQUIVALENCE (   WK(4453), SPIKPF(1)), (   WK(4726), SPKP15(1))
33649        EQUIVALENCE (   WK(4913), SPKP16(1))
33650        EQUIVALENCE (NRK(1,1), NRKLIN(1))
33651        EQUIVALENCE (NRKLIN(   1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
33652        EQUIVALENCE (NRKLIN( 297),  NRKP(1)), (NRKLIN( 367),  NRKN(1))
33653        EQUIVALENCE (NRKLIN( 483), NRKK0(1))
33654        EQUIVALENCE (NURE(1,1), NURELN(1))
33655 *
33656 **** pi- p data                                                        *
33657 **** pi+ n data                                                        *
33658       DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
33659      & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
33660      & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
33661      & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
33662      & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
33663      & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
33664      & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
33665      & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
33666      & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
33667      & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
33668       DATA PLAKC /
33669      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33670      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33671      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33672      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33673      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33674      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33675      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33676      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33677      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33678      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33679      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33680      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33681       DATA PLAK0 /
33682      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33683      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33684      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33685      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33686      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33687      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33688 *                 pp   pn   np   nn                                    *
33689       DATA PLAP /
33690      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33691      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33692      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33693      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33694      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33695      & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
33696 *    app   apn   anp   ann                                             *
33697       DATA PLAN /
33698      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
33699      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33700      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33701      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
33702      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33703      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33704      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
33705      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33706      & 3.43D0, 3.75D0, 4.07D0, 4.43D0  /
33707       DATA SIIN / 296*0.D0 /
33708       DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33709      & 1.557D0,1.615D0,1.6435D0,
33710      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33711      & 2.286D0,2.366D0,2.482D0,2.56D0,
33712      & 2.735D0,2.90D0,
33713      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33714      & 1.496D0,1.527D0,1.557D0,
33715      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33716      & 2.071D0,2.159D0,2.286D0,2.366D0,
33717      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33718      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33719      & 1.496D0,1.527D0,1.557D0,
33720      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33721      & 2.071D0,2.159D0,2.286D0,2.366D0,
33722      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33723      &                   1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33724      & 1.557D0,1.615D0,1.6435D0,
33725      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33726      & 2.286D0,2.366D0,2.482D0,2.56D0,
33727      &  2.735D0, 2.90D0/
33728       DATA UMOKC/ 1.44D0,
33729      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33730      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33731      & 3.1D0,1.44D0,
33732      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33733      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33734      & 3.1D0,1.44D0,
33735      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33736      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33737      & 3.1D0,1.44D0,
33738      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33739      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33740      &  3.1D0/
33741       DATA UMOK0/ 1.44D0,
33742      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33743      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33744      & 3.1D0,1.44D0,
33745      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33746      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33747      &  3.1D0/
33748 *                 pp   pn   np   nn                                    *
33749       DATA UMOP/
33750      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33751      & 3.D0,3.1D0,3.2D0,
33752      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33753      & 3.D0,3.1D0,3.2D0,
33754      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33755      & 3.D0,3.1D0,3.2D0/
33756 *    app   apn   anp   ann                                             *
33757       DATA UMON /
33758      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33759      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33760      & 3.D0,3.1D0,3.2D0,
33761      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33762      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33763      & 3.D0,3.1D0,3.2D0,
33764      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33765      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33766      &  3.D0,3.1D0,3.2D0/
33767 **** reaction channel state particles                                  *
33768       DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
33769      & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
33770      & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
33771      & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
33772      & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
33773      & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
33774      & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
33775      & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
33776      & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
33777      & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
33778       DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
33779      & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
33780      & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
33781      & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
33782      & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
33783      & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
33784      & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
33785      & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
33786 *                                                                      *
33787 *   k0 p   k0 n   ak0 p   ak/ n                                        *
33788 *                                                                      *
33789       DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
33790      & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13,   22, 13, 21, 23,
33791      & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
33792      & 53, 47, 1, 103, 0, 93, 0/
33793 *   pp  pn   np   nn                                                   *
33794       DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
33795      & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
33796      & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
33797      & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
33798 *     app   apn   anp   ann                                            *
33799       DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
33800      & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
33801      & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
33802      & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
33803      & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
33804      & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
33805      & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
33806 **** channel cross section                                             *
33807       DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
33808      & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
33809      & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
33810      & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
33811      & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
33812      &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
33813      & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
33814      & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
33815      &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
33816      & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
33817      & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
33818      & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
33819      & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
33820      & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
33821      & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
33822      & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
33823      & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
33824      & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
33825      & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
33826      & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
33827 **** pi+ n data                                                        *
33828       DATA SPIKPU/   0.D0, 25.D0, 13.D0,  11.D0, 10.5D0, 14.D0,  20.D0,
33829      & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33830      & 10.D0, 10.D0, 9.5D0,  9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33831      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0,   5.5D0,  4.8D0,
33832      & 4.2D0, 7.5D0, 3.4D0,  2.5D0, 2.5D0, 2.1D0, 1.4D0,   1.D0,   .8D0,
33833      &  .6D0, .46D0,  .3D0, .2D0, .15D0, .13D0, 11*0.D0,  .95D0,  .65D0,
33834      & .48D0, .35D0,  .2D0, .18D0, .17D0, .16D0,  .15D0,   .1D0,  .09D0,
33835      & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0,  .2D0,   .1D0,
33836      & .08D0, .06D0, .045D0,   .03D0, .02D0, .01D0,      .005D0, .003D0,
33837      & 12*0.D0, .3D0, .24D0,   .18D0, .15D0, .13D0,  .12D0, .11D0, .1D0,
33838      & .09D0,  .08D0, .05D0,   .04D0, .03D0,  0.D0, 0.16D0, .7D0, 1.3D0,
33839      & 3.1D0,  4.5D0,  2.D0, 18*0.D0, 3*.0D0,  0.D0, 0.D0, 4.0D0, 11.D0,
33840      & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0,  1.5D0, .9D0, .55D0,
33841      &  .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0,   2.25D0, 3.3D0,
33842      & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
33843      & .64D0,  1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0,  4.4D0,   3.D0, 1.8D0,
33844      &  .9D0, .53D0, .28D0,      10*0.D0, 2*0.D0,  .25D0,  .82D0,
33845      & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0,  5.7D0, 3.9D0, 2.35D0, 1.15D0,
33846      & .69D0, .37D0, 10*0.D0,     7*0.D0,   .0D0, .34D0,  1.5D0, 3.47D0,
33847      & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0,  .3D0,  .15D0, 6*0.D0/
33848 *
33849       DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33850      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
33851      & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
33852      & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
33853      & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
33854      & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
33855      & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
33856      & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
33857      & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
33858      & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
33859      & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
33860      & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
33861      & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
33862      & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
33863      & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
33864      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33865      & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
33866      & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
33867      & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
33868      & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
33869 **** pi- p data                                                        *
33870       DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
33871      & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33872      & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33873      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33874      & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
33875      & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
33876      & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
33877      & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
33878      & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
33879      & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
33880      & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
33881      & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
33882      & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
33883      & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
33884      & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
33885      & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
33886      & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
33887      & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
33888      & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33889 *
33890       DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33891      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
33892      & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
33893      & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
33894      & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
33895      & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
33896      & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
33897      & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
33898      & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
33899      & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
33900      & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
33901      & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
33902      & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
33903      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33904      & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
33905      & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
33906      & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
33907      & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
33908      & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
33909      & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
33910 **** pi- n data                                                        *
33911       DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
33912      & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
33913      & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
33914      & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
33915      & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
33916      & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
33917      & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
33918      & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
33919      & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
33920      & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
33921      & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
33922      & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
33923      & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
33924      & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
33925      & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
33926      & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
33927      & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
33928      & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
33929      & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
33930      & 3.3D0, 5.4D0, 7.D0 /
33931 **** k+  p data                                                        *
33932       DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
33933      & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
33934      & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
33935      & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
33936      & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33937      & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
33938      & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
33939      & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
33940      & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
33941      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33942      & 1.71D0, 1.6D0, 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,
33944      & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
33945 **** k+  n data                                                        *
33946       DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
33947      & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
33948      & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
33949      & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
33950      & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33951      & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
33952      & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
33953      & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
33954      & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
33955      & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
33956      & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
33957      & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
33958      & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
33959      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33960      & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
33961      & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
33962      & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
33963      & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
33964      & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
33965 **** k-  p data                                                        *
33966       DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
33967      &     7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
33968      &    0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
33969      &    .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
33970      &    0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
33971      &    .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
33972      &    0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
33973      &    .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
33974      &    0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
33975      &    .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
33976      &    0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
33977      &    .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
33978       DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
33979      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
33980      & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
33981      & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
33982      & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,  3*0.D0, 1.0D0, 3.03D0,
33983      & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
33984      & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
33985      & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
33986      & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
33987      & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
33988      & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
33989      & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
33990      & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
33991      & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
33992      & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
33993      & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
33994      & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
33995      & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
33996      & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
33997      & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
33998      & 10*0.D0/
33999 ***** k- n data                                                        *
34000       DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
34001      &        3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
34002      &        0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
34003      &        1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
34004      &        0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
34005      &        .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
34006      &        0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
34007      &       .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
34008       DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34009      &  14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
34010      &  1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
34011      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
34012      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
34013      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
34014      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
34015      &  7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
34016      &  .39D0, .22D0, .07D0, 0.D0,
34017      &  6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
34018      &  4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
34019      &  10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
34020      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34021      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34022      &  9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
34023      &  5.10D0, 5.44D0, 5.3D0,
34024      &  4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
34025 *****  p p data                                                        *
34026       DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34027      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34028      &              0.D0, 3.6D0, 1.7D0, 10*0.D0,
34029      &              .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
34030      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34031      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34032      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34033      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34034      &              16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
34035      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
34036      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
34037      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34038      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34039      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34040      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34041 *****  p n data                                                        *
34042       DATA SPIKP0/ 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, 1.8D0, .2D0,  12*0.D0,
34045      &              3.2D0, 6.05D0, 9.9D0, 5.1D0,
34046      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34047      &              2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34048      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34049      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34050      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34051      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34052      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34053      &              10*0.D0, .7D0, 5.1D0, 8.D0,
34054      &              10*0.D0, .7D0, 5.1D0, 8.D0,
34055      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
34056      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
34057      &              7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
34058      &              7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
34059      &              5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
34060 *   nn - data                                                          *
34061 *                                                                      *
34062       DATA SPKPV/  0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34063      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34064      &              0.D0, 3.6D0, 1.7D0, 12*0.D0,
34065      &              8.7D0, 17.7D0, 18.8D0, 15.9D0,
34066      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34067      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34068      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34069      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
34070      &              11.D0, 5.5D0, 3.5D0,
34071      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
34072      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
34073      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34074      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34075      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34076      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34077 ****************   ap - p - data                                       *
34078       DATA SAPPEL/ 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34079      &  50.D0,  50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34080      &  25.D0,  22.D0, 21.D0, 20.D0, 18.D0, 17.D0,  11*0.D0,
34081      &  .05D0,  .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34082      &  0.D0,  1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34083      &  .1D0,  .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34084      &  0.D0,  55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
34085      &  10.D0,  7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
34086      &  1.55D0,  1.3D0, .95D0, .75D0,
34087      &  0.D0,  3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34088      &  .25D0,  .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34089      & .01D0,  .008D0, .006D0, .005D0/
34090       DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34091      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34092      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
34093      & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
34094      & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
34095      & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
34096      & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
34097      & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
34098      & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
34099      & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
34100      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34101      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34102      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34103      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
34104      & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
34105      & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
34106      & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
34107      & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
34108      & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
34109      & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
34110 ****************   ap - n - data                                       *
34111       DATA SAPNEL/
34112      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0,  68.D0, 65.D0,
34113      & 50.D0, 50.D0,  43.D0,  42.D0,  40.5D0, 35.D0, 30.D0,  28.D0,
34114      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0,  17.D0, 11*0.D0,
34115      & .05D0, .15D0, .18D0,  .2D0,    .2D0,  .3D0,  .4D0,   .6D0,  .7D0,
34116      & .85D0,  0.D0,  1.D0,  .9D0,    .46D0, .3D0,  .23D0, .18D0, .16D0,
34117      & .14D0,  .1D0, .08D0, .05D0,    .02D0, .015D0, 4*.011D0, 3*.005D0,
34118      & 0.D0,  3.3D0,  3.D0, 1.5D0,     1.D0, .7D0,  .4D0,  .35D0, .4D0,
34119      & .25D0, .18D0, .08D0, .04D0,    .03D0, .023D0, .016D0, .014D0,
34120      & .01D0, .008D0, .006D0, .005D0 /
34121        DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34122      &  84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34123      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34124      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34125      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34126      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34127      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34128      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34129      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34130      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34131      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34132      & 4.9D0, 8.5D0,  15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34133      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34134      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34135 *                                                                      *
34136 *                                                                      *
34137 ****************   an - p - data                                       *
34138 *                                                                      *
34139       DATA SANPEL/
34140      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
34141      & 50.D0, 43.D0,  42.D0,  40.5D0, 35.D0, 30.D0, 28.D0,
34142      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0, 17.D0, 11*0.D0, .05D0,
34143      & .15D0, .18D0,   .2D0,   .2D0,   .3D0,  .4D0, .6D0,   .7D0, .85D0,
34144      & 0.D0,   1.D0,   .9D0,  .46D0,  .3D0,  .23D0, .18D0, .16D0, .14D0,
34145      & .1D0,  .08D0,  .05D0,  .02D0, .015D0, 4*.011D0, 3*.005D0,
34146      & 0.D0,  3.3D0,  3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
34147      & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34148      & .01D0, .008D0, .006D0, .005D0 /
34149       DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34150      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34151      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34152      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34153      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34154      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34155      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34156      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34157      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34158      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34159      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34160      & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34161      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34162      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34163 ****  ko - n - data                                                    *
34164       DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
34165      &      6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
34166      &      0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
34167      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34168      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34169      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34170      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34171      &    4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
34172      &     1.4D0, 1.2D0, 1.05D0, .9D0, .66D0,  .5D0,
34173      &    7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
34174      &   11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
34175      &    4.85D0, 4.9D0,
34176      &   10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
34177      &    6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
34178      &    2.85D0, 2.35D0, 2.01D0, 1.8D0,
34179      &   12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
34180      &   12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0  /
34181 **** ako - p - data                                                    *
34182       DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
34183      & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
34184      & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
34185      & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
34186      & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
34187      & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
34188      & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
34189      & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34190      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
34191      & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
34192      & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
34193      & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
34194      & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
34195      & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
34196      & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
34197      & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
34198      & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
34199      & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
34200      & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
34201      & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
34202      & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
34203       DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
34204      & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
34205 *=                                               end*block.blkdt3      *
34206       END
34207 *$ CREATE DT_QEL_POL.FOR
34208 *COPY DT_QEL_POL
34209 *
34210 *===qel_pol============================================================*
34211 *
34212       SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
34213
34214       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34215       SAVE
34216
34217       CALL DT_MASS_INI
34218       CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34219
34220       RETURN
34221       END
34222
34223 *$ CREATE DT_GEN_QEL.FOR
34224 *COPY DT_GEN_QEL
34225 C==================================================================
34226 C   Generation of  a Quasi-Elastic neutrino scattering
34227 C==================================================================
34228 *
34229 *===gen_qel============================================================*
34230 *
34231       SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34232
34233 C...Generate a quasi-elastic   neutrino/antineutrino
34234 C.  Interaction on a nuclear target
34235 C.  INPUT  : LTYP = neutrino type (1,...,6)
34236 C.           ENU (GeV) = neutrino energy
34237 C----------------------------------------------------
34238
34239       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34240       SAVE
34241
34242       PARAMETER ( LINP = 10 ,
34243      &            LOUT = 6 ,
34244      &            LDAT = 9 )
34245       PARAMETER (MAXLND=4000)
34246       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34247
34248 * nuclear potential
34249       LOGICAL LFERMI
34250       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
34251      &                EBINDP(2),EBINDN(2),EPOT(2,210),
34252      &                ETACOU(2),ICOUL,LFERMI
34253
34254 * steering flags for qel neutrino scattering modules
34255       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34256 **sr - removed (not needed)
34257 C     COMMON /CBAD/  LBAD, NBAD
34258 C     COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
34259 **
34260
34261       DIMENSION PI(3),PO(3)
34262 CJR+
34263       DATA ININU/0/
34264 CJR-
34265 C     REAL*8 DBETA(3)
34266 C     REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
34267       DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
34268       DATA AMN  /0.93827231D0, 0.93956563D0/
34269       DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
34270       DATA INIPRI/0/
34271
34272 C     DATA PFERMI/0.22D0/
34273 CGB+...Binding Energy
34274       DATA EBIND/0.008D0/
34275 CGB-...
34276
34277       ININU=ININU+1
34278       IF(ININU.EQ.1)NDSIG=0
34279       LBAD = 0
34280       enu0=enu
34281 c      write(*,*) enu0
34282 C...Lepton mass
34283       AML = AML0(LTYP)       !  massa leptoni
34284       AML2 = AML**2          !  massa leptoni **2
34285 C...Particle labels (LUND)
34286       N = 5
34287       K(1,1) = 21
34288       K(2,1) = 21
34289       K(3,1) = 21
34290       K(3,3) = 1
34291       K(4,1) = 1
34292       K(4,3) = 1
34293       K(5,1) = 1
34294       K(5,3) = 2
34295       K0 = (LTYP-1)/2          !  2
34296       K1 = LTYP/2              !  2
34297       KA = 12 + 2*K0           !  16
34298       IS = -1 + 2*LTYP - 4*K1  !  -1 +10 -8 = 1
34299       K(1,2) = IS*KA
34300       K(4,2) = IS*(KA-1)
34301       K(3,2) = IS*24
34302       LNU = 2 - LTYP + 2*K1    !  2 - 5 + 2 = - 1
34303       IF (LNU .EQ. 2)  THEN
34304         K(2,2) = 2212
34305         K(5,2) = 2112
34306         AMI = AMN(1)
34307         AMF = AMN(2)
34308 CJR+
34309         PFERMI=PFERMN(2)
34310 CJR-
34311       ELSE
34312         K(2,2) = 2112
34313         K(5,2) = 2212
34314         AMI = AMN(2)
34315         AMF = AMN(1)
34316 CJR+
34317         PFERMI=PFERMP(2)
34318 CJR-
34319       ENDIF
34320       AMI2 = AMI**2
34321       AMF2 = AMF**2
34322
34323       DO IGB=1,5
34324         P(3,IGB) = 0.
34325         P(4,IGB) = 0.
34326         P(5,IGB) = 0.
34327       END DO
34328
34329       NTRY = 0
34330 CGB+...
34331       EFMAX  = SQRT(PFERMI**2 + AMI2) -AMI             ! max. Fermi Energy
34332       ENWELL = EFMAX + EBIND ! depth of nuclear potential well
34333 CGB-...
34334
34335   100 CONTINUE
34336
34337 C...4-momentum initial lepton
34338       P(1,5) = 0.     ! massa
34339       P(1,4) = ENU0    ! energia
34340       P(1,1) = 0.     ! px
34341       P(1,2) = 0.     ! py
34342       P(1,3) = ENU0    ! pz
34343
34344 C     PF = PFERMI*PYR(0)**(1./3.)
34345 c       write(23,*) PYR(0)
34346 c      write(*,*) 'Pfermi=',PF
34347 c      PF = 0.
34348       NTRY=NTRY+1
34349 C     IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
34350       IF (NTRY .GT. 500)  THEN
34351         LBAD = 1
34352         WRITE (LOUT,1001)  NBAD, ENU
34353         RETURN
34354       ENDIF
34355 C     CT = -1. + 2.*PYR(0)
34356 c      CT = -1.
34357 C     ST =  SQRT(1.-CT*CT)
34358 C     F = 2.*3.1415926*PYR(0)
34359 c      F = 0.
34360
34361 C     P(2,4) = SQRT(PF*PF + MI2) - EBIND  ! energia
34362 C     P(2,1) = PF*ST*COS(F)               ! px
34363 C     P(2,2) = PF*ST*SIN(F)               ! py
34364 C     P(2,3) = PF*CT                      ! pz
34365 C     P(2,5) = SQRT(P(2,4)**2-PF*PF)      ! massa
34366        P(2,1) = P21
34367        P(2,2) = P22
34368        P(2,3) = P23
34369        P(2,4) = P24
34370        P(2,5) = P25
34371       beta1=-p(2,1)/p(2,4)
34372       beta2=-p(2,2)/p(2,4)
34373       beta3=-p(2,3)/p(2,4)
34374       N=2
34375 C      WRITE(6,*)' before transforming into target rest frame'
34376
34377       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
34378
34379 C      print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
34380       N=5
34381
34382       phi11=atan(p(1,2)/p(1,3))
34383       pi(1)=p(1,1)
34384       pi(2)=p(1,2)
34385       pi(3)=p(1,3)
34386
34387       CALL DT_TESTROT(PI,Po,PHI11,1)
34388       DO ll=1,3
34389         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34390       END DO
34391 c        WRITE(*,*) po
34392       p(1,1)=po(1)
34393       p(1,2)=po(2)
34394       p(1,3)=po(3)
34395       phi12=atan(p(1,1)/p(1,3))
34396
34397       pi(1)=p(1,1)
34398       pi(2)=p(1,2)
34399       pi(3)=p(1,3)
34400       CALL DT_TESTROT(Pi,Po,PHI12,2)
34401       DO ll=1,3
34402         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34403       END DO
34404 c        WRITE(*,*) po
34405       p(1,1)=po(1)
34406       p(1,2)=po(2)
34407       p(1,3)=po(3)
34408
34409       enu=p(1,4)
34410
34411 C...Kinematical limits in Q**2
34412 c      S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) !            ????
34413       S = P(2,5)**2 + 2.*ENU*P(2,5)
34414       SQS = SQRT(S)                          ! E centro massa
34415       IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
34416       ELF = (S-AMF2+AML2)/(2.*SQS)           ! energia leptone finale p
34417       PSTAR = (S-P(2,5)**2)/(2.*SQS)       ! p* neutrino nel c.m.
34418       PLF = SQRT(ELF**2-AML2)               ! 3-momento leptone finale
34419       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)    ! + o -
34420       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)    ! according con cos(theta)
34421       IF (Q2MIN .LT. 0.)   Q2MIN = 0.      ! ??? non fisico
34422
34423 C...Generate Q**2
34424       DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
34425   200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
34426       DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
34427       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
34428       CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
34429       NDSIG=NDSIG+1
34430 C     WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
34431 C    &Q2,Q2min,Q2MAX,DSIGEV
34432
34433 C...c.m. frame. Neutrino along z axis
34434       DETOT = (P(1,4)) + (P(2,4)) ! e totale
34435       DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
34436       DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
34437       DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
34438 c      WRITE(*,*)
34439 c      WRITE(*,*)
34440 C      WRITE(*,*) 'Input values laboratory frame'
34441       N=2
34442
34443       CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
34444
34445       N=5
34446 c      STHETA = ULANGL(P(1,3),P(1,1))
34447 c      write(*,*) 'stheta' ,stheta
34448 c      stheta=0.
34449 c      CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
34450 c      WRITE(*,*)
34451 c      WRITE(*,*)
34452 C      WRITE(*,*) 'Output values cm frame'
34453 C...Kinematic in c.m. frame
34454       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
34455       STSTAR = SQRT(1.-CTSTAR**2)
34456       PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
34457       P(4,5) = AML                  ! massa leptone
34458       P(4,4) = ELF                 ! e leptone
34459       P(4,3) = PLF*CTSTAR          ! px
34460       P(4,1) = PLF*STSTAR*COS(PHI) ! py
34461       P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
34462
34463       P(5,5) = AMF                  ! barione
34464       P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
34465       P(5,3) = -P(4,3)             ! px
34466       P(5,1) = -P(4,1)             ! py
34467       P(5,2) = -P(4,2)             ! pz
34468
34469       P(3,5) = -Q2
34470       P(3,1) = P(1,1)-P(4,1)
34471       P(3,2) = P(1,2)-P(4,2)
34472       P(3,3) = P(1,3)-P(4,3)
34473       P(3,4) = P(1,4)-P(4,4)
34474
34475 C...Transform back to laboratory  frame
34476 C      WRITE(*,*) 'before going back to nucl rest frame'
34477 c      CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
34478       N=5
34479
34480       CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
34481
34482 C      WRITE(*,*) 'Now back in nucl rest frame'
34483       IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
34484
34485 c********************************************
34486
34487       DO kw=1,5
34488         pi(1)=p(kw,1)
34489         pi(2)=p(kw,2)
34490         pi(3)=p(kw,3)
34491         CALL DT_TESTROT(Pi,Po,PHI12,3)
34492         DO ll=1,3
34493           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34494         END DO
34495         p(kw,1)=po(1)
34496         p(kw,2)=po(2)
34497         p(kw,3)=po(3)
34498       END DO
34499 c********************************************
34500
34501       DO kw=1,5
34502         pi(1)=p(kw,1)
34503         pi(2)=p(kw,2)
34504         pi(3)=p(kw,3)
34505         CALL DT_TESTROT(Pi,Po,PHI11,4)
34506         DO ll=1,3
34507           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34508         END DO
34509         p(kw,1)=po(1)
34510         p(kw,2)=po(2)
34511         p(kw,3)=po(3)
34512       END DO
34513
34514 c********************************************
34515
34516 C      WRITE(*,*) 'Now back in lab frame'
34517
34518       CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
34519
34520 CGB+...
34521 C...test (on final momentum of nucleon) if Fermi-blocking
34522 C...is operating
34523       ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
34524      &  - P(5,5)
34525       IF (ENUCL.LT. EFMAX) THEN
34526         IF(INIPRI.LT.10)THEN
34527           INIPRI=INIPRI+1
34528 C         WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
34529 C...the interaction is not possible due to Pauli-Blocking and
34530 C...it must be resampled
34531         ENDIF
34532         GOTO 100
34533       ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
34534         IF(INIPRI.LT.10)THEN
34535           INIPRI=INIPRI+1
34536 C     WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
34537         ENDIF
34538 C                      Reject (J:R) here all these events
34539 C                      are otherwise rejected in dpmjet
34540         GOTO 100
34541 C...the interaction is possible, but the nucleon remains inside
34542 C...the nucleus. The nucleus is therefore left excited.
34543 C...We treat this case as a nucleon with 0 kinetic energy.
34544 C       P(5,5) = AMF
34545 C       P(5,4) = AMF
34546 C       P(5,1) = 0.
34547 C       P(5,2) = 0.
34548 C       P(5,3) = 0.
34549       ELSE IF (ENUCL.GE.ENWELL) THEN
34550 C     WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
34551 C...the interaction is possible, the nucleon can exit the nucleus
34552 C...but the nuclear well depth must be subtracted. The nucleus could be
34553 C...left in an excited state.
34554         Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
34555 C       P(5,4) = ENUCL-ENWELL + AMF
34556         Pnucl = SQRT(P(5,4)**2-AMF**2)
34557 C...The 3-momentum is scaled assuming that the direction remains
34558 C...unaffected
34559         P(5,1) = P(5,1) * Pnucl/Pstart
34560         P(5,2) = P(5,2) * Pnucl/Pstart
34561         P(5,3) = P(5,3) * Pnucl/Pstart
34562 C     WRITE(6,*)' qel new P(5,4) ',P(5,4)
34563       ENDIF
34564 CGB-...
34565       DSIGSU=DSIGSU+DSIGEV
34566
34567          GA=P(4,4)/P(4,5)
34568          BGX=P(4,1)/P(4,5)
34569          BGY=P(4,2)/P(4,5)
34570          BGZ=P(4,3)/P(4,5)
34571 *
34572          DBETB(1)=BGX/GA
34573          DBETB(2)=BGY/GA
34574          DBETB(3)=BGZ/GA
34575          IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
34576
34577             CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
34578
34579          ENDIF
34580 c
34581 C      PRINT*,' FINE   EVENTO '
34582       enu=enu0
34583       RETURN
34584
34585  1001 FORMAT(2X, 'DT_GEN_QEL   : event rejected ', I5,  G10.3)
34586       END
34587
34588 *$ CREATE DT_MASS_INI.FOR
34589 *COPY DT_MASS_INI
34590 C====================================================================
34591 C.  Masses
34592 C====================================================================
34593 *
34594 *===mass_ini===========================================================*
34595 *
34596       SUBROUTINE DT_MASS_INI
34597 C...Initialize  the kinematics for the quasi-elastic cross section
34598
34599       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34600       SAVE
34601
34602 * particle masses used in qel neutrino scattering modules
34603       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34604      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34605      &                EMPROTSQ,EMNEUTSQ,EMNSQ
34606
34607       EML(1) = 0.51100D-03   ! e-
34608       EML(2) = EML(1)        ! e+
34609       EML(3) = 0.105659D0      ! mu-
34610       EML(4) = EML(3)        ! mu+
34611       EML(5) = 1.7777D0        ! tau-
34612       EML(6) = EML(5)        ! tau+
34613       EMPROT = 0.93827231D0    ! p
34614       EMNEUT = 0.93956563D0    ! n
34615       EMPROTSQ = EMPROT**2
34616       EMNEUTSQ = EMNEUT**2
34617       EMN = (EMPROT + EMNEUT)/2.
34618       EMNSQ = EMN**2
34619       DO J=1,3
34620         J0 = 2*(J-1)
34621         EMN1(J0+1) = EMNEUT
34622         EMN1(J0+2) = EMPROT
34623         EMN2(J0+1) = EMPROT
34624         EMN2(J0+2) = EMNEUT
34625       ENDDO
34626       DO J=1,6
34627         EMLSQ(J) = EML(J)**2
34628         ETQE(J)  = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
34629       ENDDO
34630       RETURN
34631       END
34632
34633 *$ CREATE DT_DSQEL_Q2.FOR
34634 *COPY DT_DSQEL_Q2
34635 *
34636 *===dsqel_q2===========================================================*
34637 *
34638       DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
34639
34640 C...differential cross section for  Quasi-Elastic scattering
34641 C.       nu + N -> l + N'
34642 C.  From Llewellin Smith  Phys.Rep.  3C, 261, (1971).
34643 C.
34644 C.  INPUT :  JTYP = 1,...,6    nu_e, ...., nubar_tau
34645 C.           ENU (GeV) =  Neutrino energy
34646 C.           Q2  (GeV**2) =  (Transfer momentum)**2
34647 C.
34648 C.  OUTPUT : DSQEL_Q2  = differential  cross section :
34649 C.                       dsigma/dq**2  (10**-38 cm+2/GeV**2)
34650 C------------------------------------------------------------------
34651
34652       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34653       SAVE
34654
34655 * particle masses used in qel neutrino scattering modules
34656       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34657      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34658      &                EMPROTSQ,EMNEUTSQ,EMNSQ
34659 **sr - removed (not needed)
34660 C     COMMON /CAXIAL/ FA0, AXIAL2
34661 **
34662
34663       DIMENSION SS(6)
34664       DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34665       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34666       DATA AXIAL2 /1.03D0/  ! to be checked
34667
34668       FA0=-1.253D0
34669       CSI = 3.71D0                   !  ???
34670       GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2   ! G_e(q**2)
34671       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
34672       X = Q2/(EMN*EMN)     ! emn=massa barione
34673       XA = X/4.D0
34674       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34675       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34676       FA = FA0/(1.D0 + Q2/AXIAL2)**2
34677       FFA = FA*FA
34678       FFV1 = FV1*FV1
34679       FFV2 = FV2*FV2
34680       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
34681       A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
34682       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
34683       AA = (XA+0.25D0*RM)*(A1 + A2)
34684       BB = -X*FA*(FV1 + FV2)
34685       CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
34686       SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34687       DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU)  !
34688       IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
34689
34690       RETURN
34691       END
34692
34693 *$ CREATE DT_PREPOLA.FOR
34694 *COPY DT_PREPOLA
34695 *
34696 *===prepola============================================================*
34697 *
34698       SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
34699
34700       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34701       SAVE
34702 c
34703 c By G. Battistoni and E. Scapparone (sept. 1997)
34704 c According to:
34705 c     Albright & Jarlskog, Nucl Phys B84 (1975) 467
34706 c
34707 c
34708       PARAMETER (MAXLND=4000)
34709       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34710
34711       COMMON /QNPOL/ POLARX(4),PMODUL
34712
34713 * particle masses used in qel neutrino scattering modules
34714       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34715      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34716      &                EMPROTSQ,EMNEUTSQ,EMNSQ
34717
34718 * steering flags for qel neutrino scattering modules
34719       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34720 **sr - removed (not needed)
34721 C     COMMON /CAXIAL/ FA0, AXIAL2
34722 C     COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
34723 C    &        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
34724 **
34725       REAL*8 POL(4,4),BB2(3)
34726       DIMENSION SS(6)
34727 C     DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34728       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34729 **sr uncommented since common block CAXIAL is now commented
34730       DATA AXIAL2 /1.03D0/  ! to be checked
34731 **
34732
34733       RML=P(4,5)
34734       RMM=0.93960D+00
34735       FM2 = RMM**2
34736       MPI = 0.135D+00
34737       OLDQ2=Q2
34738       FA0=-1.253D+00
34739       CSI = 3.71D+00                      !
34740       GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2   ! G_e(q**2)
34741       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
34742       X = Q2/(EMN*EMN)     ! emn=massa barione
34743       XA = X/4.D0
34744       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34745       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34746       FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
34747       FFA = FA*FA
34748       FFV1 = FV1*FV1
34749       FFV2 = FV2*FV2
34750       FP=2.D0*FA*RMM/(MPI**2 + Q2)
34751       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
34752       A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
34753       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
34754       AA = (XA+0.25D+00*RM)*(A1 + A2)
34755       BB = -X*FA*(FV1 + FV2)
34756       CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
34757       SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34758
34759       OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2   )  ! articolo di ll...-smith
34760       OMEGA2=4.D+00*CC
34761       OMEGA3=2.D+00*FA*(FV1+FV2)
34762       OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
34763      1     (Q2/FM2))*FP**2)
34764       OMEGA5=OMEGA2
34765       OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
34766       WW1=2.D+00*OMEGA1*EMN**2
34767       WW2=2.D+00*OMEGA2*EMN**2
34768       WW3=2.D+00*OMEGA3*EMN**2
34769       WW4=2.D+00*OMEGA4*EMN**2
34770       WW5=2.D+00*OMEGA5*EMN**2
34771
34772       DO I=1,3
34773         BB2(I)=-P(4,I)/P(4,4)
34774       END DO
34775 c      WRITE(*,*)
34776 c      WRITE(*,*)
34777 c      WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
34778       N=5
34779
34780       CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
34781
34782 * NOW PARTICLES ARE IN THE SCATTERED LEPTON  REST FRAME
34783 c      WRITE(*,*)
34784 c      WRITE(*,*)
34785 c      WRITE(*,*) 'Prepola: now in lepton rest frame'
34786       EE=ENU
34787       QM2=Q2+RML**2
34788       U=Q2/(2.*RMM)
34789       FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
34790      +     (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
34791      +     ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
34792
34793       FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
34794      +     - ((RML**2)/FM2)*WW4                        !<=FM2 inv di RMM!!
34795
34796       FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
34797
34798       DO I=1,3
34799         POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
34800         POLARX(I)=POL(4,I)
34801       END DO
34802
34803       PMODUL=0.D0
34804       DO I=1,3
34805         PMODUL=PMODUL+POL(4,I)**2
34806       END DO
34807
34808       IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
34809          IF(NEUDEC.EQ.1) THEN
34810             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
34811      +        ETL,PXL,PYL,PZL,
34812      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34813 c
34814 c     Tau has decayed in muon
34815 c
34816          ENDIF
34817          IF(NEUDEC.EQ.2) THEN
34818             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
34819      +        ETL,PXL,PYL,PZL,
34820      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34821 c
34822 c     Tau has decayed in electron
34823 c
34824          ENDIF
34825          K(4,1)=15
34826          K(4,4) = 6
34827          K(4,5) = 8
34828          N=N+3
34829 c
34830 c     fill common for muon(electron)
34831 c
34832          P(6,1)=PXL
34833          P(6,2)=PYL
34834          P(6,3)=PZL
34835          P(6,4)=ETL
34836          K(6,1)=1
34837          IF(JTYP.EQ.5) THEN
34838             IF(NEUDEC.EQ.1) THEN
34839                P(6,5)=EML(JTYP-2)
34840                K(6,2)=13
34841             ELSEIF(NEUDEC.EQ.2) THEN
34842                P(6,5)=EML(JTYP-4)
34843                K(6,2)=11
34844             ENDIF
34845          ELSEIF(JTYP.EQ.6) THEN
34846             IF(NEUDEC.EQ.1) THEN
34847                K(6,2)=-13
34848             ELSEIF(NEUDEC.EQ.2) THEN
34849                K(6,2)=-11
34850             ENDIF
34851          END IF
34852          K(6,3)=4
34853          K(6,4)=0
34854          K(6,5)=0
34855 c
34856 c     fill common for tau_(anti)neutrino
34857 c
34858          P(7,1)=PXB
34859          P(7,2)=PYB
34860          P(7,3)=PZB
34861          P(7,4)=ETB
34862          P(7,5)=0.
34863          K(7,1)=1
34864          IF(JTYP.EQ.5) THEN
34865             K(7,2)=16
34866          ELSEIF(JTYP.EQ.6) THEN
34867             K(7,2)=-16
34868          END IF
34869          K(7,3)=4
34870          K(7,4)=0
34871          K(7,5)=0
34872 c
34873 c     Fill common for muon(electron)_(anti)neutrino
34874 c
34875          P(8,1)=PXN
34876          P(8,2)=PYN
34877          P(8,3)=PZN
34878          P(8,4)=ETN
34879          P(8,5)=0.
34880          K(8,1)=1
34881          IF(JTYP.EQ.5) THEN
34882             IF(NEUDEC.EQ.1) THEN
34883                K(8,2)=-14
34884             ELSEIF(NEUDEC.EQ.2) THEN
34885                K(8,2)=-12
34886             ENDIF
34887          ELSEIF(JTYP.EQ.6) THEN
34888             IF(NEUDEC.EQ.1) THEN
34889                K(8,2)=14
34890             ELSEIF(NEUDEC.EQ.2) THEN
34891                K(8,2)=12
34892             ENDIF
34893          END IF
34894          K(8,3)=4
34895          K(8,4)=0
34896          K(8,5)=0
34897       ENDIF
34898 c      WRITE(*,*)
34899 c      WRITE(*,*)
34900
34901 c      IF(PMODUL.GE.1.D+00) THEN
34902 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34903 c        write(*,*) pmodul
34904 c        DO I=1,3
34905 c          POL(4,I)=POL(4,I)/PMODUL
34906 c          POLARX(I)=POL(4,I)
34907 c        END DO
34908 c        PMODUL=0.
34909 c        DO I=1,3
34910 c          PMODUL=PMODUL+POL(4,I)**2
34911 c        END DO
34912 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34913 c
34914 c      ENDIF
34915
34916 c      WRITE(*,*) 'PMODUL = ',PMODUL
34917
34918 c      WRITE(*,*)
34919 c      WRITE(*,*)
34920 c      WRITE(*,*) 'prepola: Now back to nucl rest frame'
34921
34922       CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
34923
34924       XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
34925       YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
34926       ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
34927       DO NDC =6,8
34928          V(NDC,1) = XDC
34929          V(NDC,2) = YDC
34930          V(NDC,3) = ZDC
34931       END DO
34932
34933       RETURN
34934       END
34935
34936 *$ CREATE DT_TESTROT.FOR
34937 *COPY DT_TESTROT
34938 *
34939 *===testrot============================================================*
34940 *
34941       SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
34942
34943       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34944       SAVE
34945
34946       DIMENSION ROT(3,3),PI(3),PO(3)
34947
34948       IF (MODE.EQ.1) THEN
34949          ROT(1,1) = 1.D0
34950          ROT(1,2) = 0.D0
34951          ROT(1,3) = 0.D0
34952          ROT(2,1) = 0.D0
34953          ROT(2,2) = COS(PHI)
34954          ROT(2,3) = -SIN(PHI)
34955          ROT(3,1) = 0.D0
34956          ROT(3,2) = SIN(PHI)
34957          ROT(3,3) = COS(PHI)
34958       ELSEIF (MODE.EQ.2) THEN
34959          ROT(1,1) = 0.D0
34960          ROT(1,2) = 1.D0
34961          ROT(1,3) = 0.D0
34962          ROT(2,1) = COS(PHI)
34963          ROT(2,2) = 0.D0
34964          ROT(2,3) = -SIN(PHI)
34965          ROT(3,1) = SIN(PHI)
34966          ROT(3,2) = 0.D0
34967          ROT(3,3) = COS(PHI)
34968       ELSEIF (MODE.EQ.3) THEN
34969          ROT(1,1) = 0.D0
34970          ROT(2,1) = 1.D0
34971          ROT(3,1) = 0.D0
34972          ROT(1,2) = COS(PHI)
34973          ROT(2,2) = 0.D0
34974          ROT(3,2) = -SIN(PHI)
34975          ROT(1,3) = SIN(PHI)
34976          ROT(2,3) = 0.D0
34977          ROT(3,3) = COS(PHI)
34978       ELSEIF (MODE.EQ.4) THEN
34979          ROT(1,1) = 1.D0
34980          ROT(2,1) = 0.D0
34981          ROT(3,1) = 0.D0
34982          ROT(1,2) = 0.D0
34983          ROT(2,2) = COS(PHI)
34984          ROT(3,2) = -SIN(PHI)
34985          ROT(1,3) = 0.D0
34986          ROT(2,3) = SIN(PHI)
34987          ROT(3,3) = COS(PHI)
34988       ELSE
34989          STOP ' TESTROT: mode not supported!'
34990       ENDIF
34991       DO 1 J=1,3
34992         PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
34993     1 CONTINUE
34994
34995       RETURN
34996       END
34997
34998 *$ CREATE DT_LEPDCYP.FOR
34999 *COPY DT_LEPDCYP
35000 *
35001 *===lepdcyp============================================================*
35002 *
35003       SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
35004      &                      ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
35005 C
35006 C-----------------------------------------------------------------
35007 C
35008 C   Author   :- G. Battistoni         10-NOV-1995
35009 C
35010 C=================================================================
35011 C
35012 C   Purpose   : performs decay of polarized lepton in
35013 C               its rest frame: a => b + l + anti-nu
35014 C               (Example: mu- => nu-mu + e- + anti-nu-e)
35015 C               Polarization is assumed along Z-axis
35016 C               WARNING:
35017 C               1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
35018 C                  OF NEGLIGIBLE MASS
35019 C               2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
35020 C                  IN THIS VERSION
35021 C
35022 C   Method    : modifies phase space distribution obtained
35023 C               by routine EXPLOD using a rejection against the
35024 C               matrix element for unpolarized lepton decay
35025 C
35026 C   Inputs    : Mass of a :  AMA
35027 C               Mass of l :  AML
35028 C               Polar. of a: POL
35029 C               (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
35030 C                                                 POL = -1)
35031 C
35032 C   Outputs   : kinematic variables in the rest frame of decaying lepton
35033 C               ETL,PXL,PYL,PZL 4-moment of l
35034 C               ETB,PXB,PYB,PZB 4-moment of b
35035 C               ETN,PXN,PYN,PZN 4-moment of anti-nu
35036 C
35037 C============================================================
35038 C +
35039 C Declarations.
35040 C -
35041       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35042       SAVE
35043
35044       PARAMETER ( LINP = 10 ,
35045      &            LOUT = 6 ,
35046      &            LDAT = 9 )
35047
35048       PARAMETER ( KALGNM = 2 )
35049       PARAMETER ( ANGLGB = 5.0D-16 )
35050       PARAMETER ( ANGLSQ = 2.5D-31 )
35051       PARAMETER ( AXCSSV = 0.2D+16 )
35052       PARAMETER ( ANDRFL = 1.0D-38 )
35053       PARAMETER ( AVRFLW = 1.0D+38 )
35054       PARAMETER ( AINFNT = 1.0D+30 )
35055       PARAMETER ( AZRZRZ = 1.0D-30 )
35056       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
35057       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
35058       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
35059       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
35060       PARAMETER ( CSNNRM = 2.0D-15 )
35061       PARAMETER ( DMXTRN = 1.0D+08 )
35062       PARAMETER ( ZERZER = 0.D+00 )
35063       PARAMETER ( ONEONE = 1.D+00 )
35064       PARAMETER ( TWOTWO = 2.D+00 )
35065       PARAMETER ( THRTHR = 3.D+00 )
35066       PARAMETER ( FOUFOU = 4.D+00 )
35067       PARAMETER ( FIVFIV = 5.D+00 )
35068       PARAMETER ( SIXSIX = 6.D+00 )
35069       PARAMETER ( SEVSEV = 7.D+00 )
35070       PARAMETER ( EIGEIG = 8.D+00 )
35071       PARAMETER ( ANINEN = 9.D+00 )
35072       PARAMETER ( TENTEN = 10.D+00 )
35073       PARAMETER ( HLFHLF = 0.5D+00 )
35074       PARAMETER ( ONETHI = ONEONE / THRTHR )
35075       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
35076       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
35077       PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
35078       PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
35079       PARAMETER ( CLIGHT = 2.99792458         D+10 )
35080       PARAMETER ( AVOGAD = 6.0221367          D+23 )
35081       PARAMETER ( AMELGR = 9.1093897          D-28 )
35082       PARAMETER ( PLCKBR = 1.05457266         D-27 )
35083       PARAMETER ( ELCCGS = 4.8032068          D-10 )
35084       PARAMETER ( ELCMKS = 1.60217733         D-19 )
35085       PARAMETER ( AMUGRM = 1.6605402          D-24 )
35086       PARAMETER ( AMMUMU = 0.113428913        D+00 )
35087       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
35088       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
35089       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
35090       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
35091       PARAMETER ( PLABRC = 0.197327053        D+00 )
35092       PARAMETER ( AMELCT = 0.51099906         D-03 )
35093       PARAMETER ( AMUGEV = 0.93149432         D+00 )
35094       PARAMETER ( AMMUON = 0.105658389        D+00 )
35095       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
35096       PARAMETER ( GEVMEV = 1.0                D+03 )
35097       PARAMETER ( EMVGEV = 1.0                D-03 )
35098       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
35099       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
35100       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
35101 C +
35102 C    variables for EXPLOD
35103 C -
35104       PARAMETER ( KPMX = 10 )
35105       DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
35106      &          PZEXPL (KPMX), ETEXPL (KPMX)
35107 C +
35108 C      test variables
35109 C -
35110 **sr - removed (not needed)
35111 C     COMMON /GBATNU/ ELERAT,NTRY
35112 **
35113 C +
35114 C     Initializes test variables
35115 C -
35116       NTRY = 0
35117       ELERAT = 0.D+00
35118 C +
35119 C     Maximum value for matrix element
35120 C -
35121       ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
35122      &  SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
35123 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
35124 C     Inputs for EXPLOD
35125 C part. no. 1 is l       (e- in mu- decay)
35126 C part. no. 2 is b       (nu-mu in mu- decay)
35127 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
35128 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
35129       NPEXPL = 3
35130       ETOTEX = AMA
35131       AMEXPL(1) = AML
35132       AMEXPL(2) = 0.D+00
35133       AMEXPL(3) = 0.D+00
35134 C +
35135 C     phase space distribution
35136 C -
35137   100 CONTINUE
35138       NTRY = NTRY + 1
35139
35140       CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
35141      &              PYEXPL, PZEXPL )
35142
35143 C +
35144 C  Calculates matrix element:
35145 C  64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
35146 C  Here CTH is the cosine of the angle between anti-nu and Z axis
35147 C -
35148       CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
35149      &  PZEXPL(3)**2 )
35150       PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
35151       PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
35152      &     PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
35153       ELEMAT = 16.D+00 * PROD1 * PROD2
35154       IF(ELEMAT.GT.ELEMAX) THEN
35155         WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
35156         STOP
35157       ENDIF
35158 C +
35159 C     Here performs the rejection
35160 C -
35161       TEST = DT_RNDM(ETOTEX) * ELEMAX
35162       IF ( TEST .GT. ELEMAT ) GO TO 100
35163 C +
35164 C     final assignment of variables
35165 C -
35166       ELERAT = ELEMAT/ELEMAX
35167       ETL = ETEXPL(1)
35168       PXL = PXEXPL(1)
35169       PYL = PYEXPL(1)
35170       PZL = PZEXPL(1)
35171       ETB = ETEXPL(2)
35172       PXB = PXEXPL(2)
35173       PYB = PYEXPL(2)
35174       PZB = PZEXPL(2)
35175       ETN = ETEXPL(3)
35176       PXN = PXEXPL(3)
35177       PYN = PYEXPL(3)
35178       PZN = PZEXPL(3)
35179   999 RETURN
35180       END
35181
35182 *$ CREATE DT_GEN_DELTA.FOR
35183 *COPY DT_GEN_DELTA
35184 C==================================================================
35185 C.  Generation of  Delta resonance events
35186 C==================================================================
35187 *
35188 *===gen_delta==========================================================*
35189 *
35190       SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
35191
35192       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35193       SAVE
35194
35195       PARAMETER ( LINP = 10 ,
35196      &            LOUT = 6 ,
35197      &            LDAT = 9 )
35198
35199 C...Generate a Delta-production neutrino/antineutrino
35200 C.  CC-interaction on a nucleon
35201 C
35202 C.  INPUT  ENU (GeV) = Neutrino Energy
35203 C.         LLEP = neutrino type
35204 C.         LTARG = nucleon target type 1=p, 2=n.
35205 C.         JINT = 1:CC, 2::NC
35206 C.
35207 C.  OUTPUT PPL(4)  4-monentum of final lepton
35208 C----------------------------------------------------
35209       PARAMETER (MAXLND=4000)
35210       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35211
35212 **sr - removed (not needed)
35213 C     COMMON /CBAD/  LBAD, NBAD
35214 **
35215
35216       DIMENSION PI(3),PO(3)
35217 C     REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
35218       DIMENSION AML0(6),AMN(2)
35219       DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
35220       DATA AMN  /0.93827231, 0.93956563/
35221       DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
35222
35223 c     WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
35224       LBAD = 0
35225 C...Final lepton mass
35226       IF (JINT.EQ.1) THEN
35227         AML = AML0(LLEP)
35228       ELSE
35229         AML = 0.
35230       ENDIF
35231       AML2 = AML**2
35232
35233 C...Particle labels (LUND)
35234       N = 5
35235       K(1,1) = 21
35236       K(2,1) = 21
35237       K(3,1) = 21
35238       K(4,1) = 1
35239       K(3,3) = 1
35240       K(4,3) = 1
35241       IF (LTARG .EQ. 1)  THEN
35242          K(2,2) = 2212
35243       ELSE
35244          K(2,2) = 2112
35245       ENDIF
35246       K0 = (LLEP-1)/2
35247       K1 = LLEP/2
35248       KA = 12 + 2*K0
35249       IS = -1 + 2*LLEP - 4*K1
35250       LNU = 2 - LLEP + 2*K1
35251       K(1,2) = IS*KA
35252       K(5,1) = 1
35253       K(5,3) = 2
35254       IF (JINT .EQ. 1)  THEN                    ! CC interactions
35255          K(3,2) = IS*24
35256          K(4,2) = IS*(KA-1)
35257         IF(LNU.EQ.1) THEN
35258           IF (LTARG .EQ. 1)  THEN
35259               K(5,2) = 2224
35260           ELSE
35261               K(5,2) = 2214
35262           ENDIF
35263         ELSE
35264           IF (LTARG .EQ. 1)  THEN
35265               K(5,2) = 2114
35266           ELSE
35267               K(5,2) = 1114
35268           ENDIF
35269         ENDIF
35270       ELSE
35271          K(3,2) = 23                           ! NC (Z0) interactions
35272          K(4,2) = K(1,2)
35273 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
35274 *                                Delta0 for neutron (LTARG=2)
35275 C        IF (LTARG .EQ. 1)  THEN
35276 C           K(5,2) = 2114
35277 C        ELSE
35278 C           K(5,2) = 2214
35279 C        ENDIF
35280          IF (LTARG .EQ. 1)  THEN
35281             K(5,2) = 2214
35282          ELSE
35283             K(5,2) = 2114
35284          ENDIF
35285 **
35286       ENDIF
35287
35288 C...4-momentum initial lepton
35289       P(1,5) = 0.
35290       P(1,4) = ENU
35291       P(1,1) = 0.
35292       P(1,2) = 0.
35293       P(1,3) = ENU
35294 C...4-momentum initial nucleon
35295       P(2,5) = AMN(LTARG)
35296 C     P(2,4) = P(2,5)
35297 C     P(2,1) = 0.
35298 C     P(2,2) = 0.
35299 C     P(2,3) = 0.
35300        P(2,1) = P21
35301        P(2,2) = P22
35302        P(2,3) = P23
35303        P(2,4) = P24
35304        P(2,5) = P25
35305       N=2
35306       beta1=-p(2,1)/p(2,4)
35307       beta2=-p(2,2)/p(2,4)
35308       beta3=-p(2,3)/p(2,4)
35309       N=2
35310
35311       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35312
35313 C     print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35314
35315       phi11=atan(p(1,2)/p(1,3))
35316       pi(1)=p(1,1)
35317       pi(2)=p(1,2)
35318       pi(3)=p(1,3)
35319
35320       CALL DT_TESTROT(PI,Po,PHI11,1)
35321       DO ll=1,3
35322        IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35323       END DO
35324       p(1,1)=po(1)
35325       p(1,2)=po(2)
35326       p(1,3)=po(3)
35327       phi12=atan(p(1,1)/p(1,3))
35328
35329       pi(1)=p(1,1)
35330       pi(2)=p(1,2)
35331       pi(3)=p(1,3)
35332       CALL DT_TESTROT(Pi,Po,PHI12,2)
35333       DO ll=1,3
35334         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35335       END DO
35336       p(1,1)=po(1)
35337       p(1,2)=po(2)
35338       p(1,3)=po(3)
35339
35340       ENUU=P(1,4)
35341
35342 C...Generate the Mass of the Delta
35343       NTRY = 0
35344 100   R = PYR(0)
35345       AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
35346       NTRY = NTRY + 1
35347       IF (NTRY .GT. 1000)  THEN
35348          LBAD = 1
35349          WRITE (LOUT,1001)  NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
35350          RETURN
35351       ENDIF
35352       IF (AMD .LT. AMDMIN)  GOTO 100
35353       ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
35354       IF (ENUU .LT. ET) GOTO 100
35355
35356 C...Kinematical  limits in Q**2
35357       S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
35358       SQS = SQRT(S)
35359       PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
35360       ELF = (S - AMD**2 + AML2)/(2.*SQS)
35361       PLF = SQRT(ELF**2 - AML2)
35362       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
35363       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
35364       IF (Q2MIN .LT. 0.)   Q2MIN = 0.
35365
35366       DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
35367 200   Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35368       DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
35369       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
35370
35371 C...Generate the kinematics of the final particles
35372       EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
35373       GAM = EISTAR/AMN(LTARG)
35374       BET = PSTAR/EISTAR
35375       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
35376       EL  = GAM*(ELF + BET*PLF*CTSTAR)
35377       PLZ = GAM*(PLF*CTSTAR + BET*ELF)
35378       PL  = SQRT(EL**2 - AML2)
35379       PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
35380       PHI = 6.28319*PYR(0)
35381       P(4,1) = PLT*COS(PHI)
35382       P(4,2) = PLT*SIN(PHI)
35383       P(4,3) = PLZ
35384       P(4,4) = EL
35385       P(4,5) = AML
35386
35387 C...4-momentum of Delta
35388       P(5,1) = -P(4,1)
35389       P(5,2) = -P(4,2)
35390       P(5,3) = ENUU-P(4,3)
35391       P(5,4) = ENUU+AMN(LTARG)-P(4,4)
35392       P(5,5) = AMD
35393
35394 C...4-momentum  of intermediate boson
35395       P(3,5) = -Q2
35396       P(3,4) = P(1,4)-P(4,4)
35397       P(3,1) = P(1,1)-P(4,1)
35398       P(3,2) = P(1,2)-P(4,2)
35399       P(3,3) = P(1,3)-P(4,3)
35400       N=5
35401
35402       DO kw=1,5
35403         pi(1)=p(kw,1)
35404         pi(2)=p(kw,2)
35405         pi(3)=p(kw,3)
35406         CALL DT_TESTROT(Pi,Po,PHI12,3)
35407         DO ll=1,3
35408           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35409         END DO
35410         p(kw,1)=po(1)
35411         p(kw,2)=po(2)
35412         p(kw,3)=po(3)
35413       END DO
35414
35415 c********************************************
35416
35417         DO kw=1,5
35418           pi(1)=p(kw,1)
35419           pi(2)=p(kw,2)
35420           pi(3)=p(kw,3)
35421           CALL DT_TESTROT(Pi,Po,PHI11,4)
35422           DO ll=1,3
35423             IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35424           END DO
35425           p(kw,1)=po(1)
35426           p(kw,2)=po(2)
35427           p(kw,3)=po(3)
35428        END DO
35429 c********************************************
35430 C         transform back into Lab.
35431
35432       CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35433
35434 C     WRITE(6,*)' Lab fram ( fermi incl.) '
35435       N=5
35436       CALL PYEXEC
35437
35438       RETURN
35439 1001  FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5,  6G10.3)
35440       END
35441
35442 *$ CREATE DT_DSIGMA_DELTA.FOR
35443 *COPY DT_DSIGMA_DELTA
35444 *
35445 *===dsigma_delta=======================================================*
35446 *
35447       DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
35448
35449       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35450       SAVE
35451
35452 C...Reaction nu + N -> lepton + Delta
35453 C.  returns the  cross section
35454 C.  dsigma/dt
35455 C.  INPUT  LNU = 1, 2  (neutrino-antineutrino)
35456 C.         QQ = t (always negative)  GeV**2
35457 C.         S  = (c.m energy)**2      GeV**2
35458 C.  OUTPUT =  10**-38 cm+2/GeV**2
35459 C-----------------------------------------------------
35460       REAL*8 MN, MN2, MN4, MD,MD2, MD4
35461       DATA MN /0.938/
35462       DATA PI /3.1415926/
35463
35464       GF = (1.1664 * 1.97)
35465       GF2 = GF*GF
35466       MN2 = MN*MN
35467       MN4 = MN2*MN2
35468       MD2 = MD*MD
35469       MD4 = MD2*MD2
35470       AML2 = AML*AML
35471       AML4 = AML2*AML2
35472       VQ  = (MN2 - MD2 - QQ)/2.
35473       VPI = (MN2 + MD2 - QQ)/2.
35474       VK  = (S + QQ - MN2 - AML2)/2.
35475       PIK = (S - MN2)/2.
35476       QK = (AML2 - QQ)/2.
35477       PIQ = (QQ + MN2 - MD2)/2.
35478       Q = SQRT(-QQ)
35479       C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
35480       C3 = SQRT(3.)*C3V/MN
35481       C4 = -C3/MD             ! attenzione al segno
35482       C5A = 1.18/(1.-QQ/0.4225)**2
35483       C32 = C3**2
35484       C42 = C4**2
35485       C5A2 = C5A**2
35486
35487       IF (LNU .EQ. 1)  THEN
35488       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35489      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35490      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35491      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35492       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35493      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35494      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35495      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35496      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35497      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
35498      . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35499      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35500      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35501      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35502      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
35503      . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
35504      . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
35505      . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
35506      . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
35507      . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35508      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35509      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35510      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35511       ELSE
35512       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35513      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35514      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35515      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35516       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35517      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35518      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35519      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35520      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35521      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
35522      . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35523      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35524      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35525      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35526      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
35527      . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
35528      . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
35529      . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
35530      . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
35531      . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35532      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35533      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35534      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35535       ENDIF
35536       ANS1=32.*ANS2
35537       ANS=ANS1/(3.*MD2)
35538       P1CM = (S-MN2)/(2.*SQRT(S))
35539       DT_DSIGMA_DELTA  = GF2/2. * ANS/(64.*PI*S*P1CM**2)
35540
35541       RETURN
35542       END
35543
35544 *$ CREATE DT_QGAUS.FOR
35545 *COPY DT_QGAUS
35546 *
35547 *===qgaus==============================================================*
35548 *
35549       SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
35550
35551       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35552       SAVE
35553
35554       DIMENSION X(5),W(5)
35555       DATA X/.1488743389D0,.4333953941D0,
35556      & .6794095682D0,.8650633666D0,.9739065285D0
35557      */
35558       DATA W/.2955242247D0,.2692667193D0,
35559      & .2190863625D0,.1494513491D0,.0666713443D0
35560      */
35561       XM=0.5D0*(B+A)
35562       XR=0.5D0*(B-A)
35563       SS=0
35564       DO 11 J=1,5
35565         DX=XR*X(J)
35566         SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
35567      &  DT_DSQEL_Q2(LTYP,ENU,XM-DX))
35568 11    CONTINUE
35569       SS=XR*SS
35570
35571       RETURN
35572       END
35573 *$ CREATE DT_DIQBRK.FOR
35574 *COPY DT_DIQBRK
35575 *
35576 *===diqbrk=============================================================*
35577 *
35578       SUBROUTINE DT_DIQBRK
35579
35580       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35581       SAVE
35582
35583 * event history
35584
35585       PARAMETER (NMXHKK=200000)
35586
35587       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35588      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35589      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35590
35591 * extended event history
35592       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35593      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35594      &                IHIST(2,NMXHKK)
35595
35596 * event flag
35597       COMMON /DTEVNO/ NEVENT,ICASCA
35598
35599 C     IF(DT_RNDM(VV).LE.0.5D0)THEN
35600 C       CALL GSQBS1(NHKK)
35601 C       CALL GSQBS2(NHKK)
35602 C       CALL USQBS1(NHKK)
35603 C       CALL USQBS2(NHKK)
35604 C       CALL GSABS1(NHKK)
35605 C       CALL GSABS2(NHKK)
35606 C       CALL USABS1(NHKK)
35607 C       CALL USABS2(NHKK)
35608 C     ELSE
35609 C       CALL GSQBS2(NHKK)
35610 C       CALL GSQBS1(NHKK)
35611 C       CALL USQBS2(NHKK)
35612 C       CALL USQBS1(NHKK)
35613 C       CALL GSABS2(NHKK)
35614 C       CALL GSABS1(NHKK)
35615 C       CALL USABS2(NHKK)
35616 C       CALL USABS1(NHKK)
35617 C     ENDIF
35618
35619       IF(DT_RNDM(VV).LE.0.5D0) THEN
35620         CALL DT_DBREAK(1)
35621         CALL DT_DBREAK(2)
35622         CALL DT_DBREAK(3)
35623         CALL DT_DBREAK(4)
35624         CALL DT_DBREAK(5)
35625         CALL DT_DBREAK(6)
35626         CALL DT_DBREAK(7)
35627         CALL DT_DBREAK(8)
35628       ELSE
35629         CALL DT_DBREAK(2)
35630         CALL DT_DBREAK(1)
35631         CALL DT_DBREAK(4)
35632         CALL DT_DBREAK(3)
35633         CALL DT_DBREAK(6)
35634         CALL DT_DBREAK(5)
35635         CALL DT_DBREAK(8)
35636         CALL DT_DBREAK(7)
35637       ENDIF
35638
35639       RETURN
35640       END
35641
35642 *$ CREATE MUSQBS2.FOR
35643 *COPY MUSQBS2
35644 C
35645 C
35646 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
35647       SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35648      *              IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
35649 C
35650 C                  USQBS-2 diagram (split target diquark)
35651 C
35652       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35653       SAVE
35654
35655       PARAMETER ( LINP = 10 ,
35656      &            LOUT = 6 ,
35657      &            LDAT = 9 )
35658
35659 * event history
35660
35661       PARAMETER (NMXHKK=200000)
35662
35663       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35664      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35665      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35666
35667 * extended event history
35668       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35669      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35670      &                IHIST(2,NMXHKK)
35671
35672 * Lorentz-parameters of the current interaction
35673       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
35674      &                UMO,PPCM,EPROJ,PPROJ
35675
35676 * diquark-breaking mechanism
35677       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
35678
35679 C
35680       PARAMETER (NTMHKK= 300)
35681       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35682      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35683      +(4,NTMHKK)
35684 *KEEP,XSEADI.
35685       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
35686      +SSMIMQ,VVMTHR
35687 *KEEP,DPRIN.
35688       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
35689       COMMON /EVFLAG/ NUMEV
35690 C
35691 C                  USQBS-2 diagram (split target diquark)
35692 C
35693 C
35694 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
35695 C     Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
35696 C
35697 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
35698 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35699 C
35700 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35701 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35702 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35703 C
35704 C
35705 C       Put new chains into COMMON /HKKTMP/
35706 C
35707       IIGLU1=NC1T-NC1P-1
35708       IIGLU2=NC2T-NC2P-1
35709       IGCOUN=0
35710 C     WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
35711       CVQ=1.D0
35712       IREJ=0
35713       IF(IPIP.EQ.2)THEN
35714 C     IF(NUMEV.EQ.-324)THEN
35715 C     WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
35716 C    *             'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
35717 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35718 C    *              IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
35719       ENDIF
35720 C
35721 C
35722 C
35723 C     determine x-values of NC1T diquark
35724       XDIQT=PHKK(4,NC1T)*2.D0/UMO
35725       XVQP=PHKK(4,NC1P)*2.D0/UMO
35726 C
35727 C     determine x-values of sea quark pair
35728 C
35729       IPCO=1
35730       ICOU=0
35731  2234 CONTINUE
35732       ICOU=ICOU+1
35733       IF(ICOU.GE.500)THEN
35734         IREJ=1
35735         IF(ISQ.EQ.3)IREJ=3
35736         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
35737         IPCO=0
35738         RETURN
35739       ENDIF
35740       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
35741      * UMO, XDIQT,XVQP
35742       XSQ=0.D0
35743       XSAQ=0.D0
35744 **NEW
35745 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
35746       IF (IPIP.EQ.1) THEN
35747          XQMAX  = XDIQT/2.0D0
35748          XAQMAX = 2.D0*XVQP/3.0D0
35749       ELSE
35750          XQMAX  = 2.D0*XVQP/3.0D0
35751          XAQMAX = XDIQT/2.0D0
35752       ENDIF
35753       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
35754       ISAQ = 6+ISQ
35755 C     write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
35756 **
35757         IF(IPCO.GE.3)
35758      &     WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35759       IF(IREJ.GE.1)THEN
35760         IF(IPCO.GE.3)
35761      &     WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35762         IPCO=0
35763         RETURN
35764       ENDIF
35765       IF(IPIP.EQ.1)THEN
35766         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35767       ELSEIF(IPIP.EQ.2)THEN
35768         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35769       ENDIF
35770       IF(IPCO.GE.3)THEN
35771         WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
35772      &  XDIQT,XVQP,XSQ,XSAQ
35773       ENDIF
35774 C
35775 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
35776 C
35777 C     XSQ=0.D0
35778       IF(IPIP.EQ.1)THEN
35779         XDIQT=XDIQT-XSQ
35780         XVQP =XVQP -XSAQ
35781       ELSEIF(IPIP.EQ.2)THEN
35782         XDIQT=XDIQT-XSAQ
35783         XVQP =XVQP -XSQ
35784       ENDIF
35785       IF(IPCO.GE.3)
35786      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
35787 C
35788 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35789 C
35790       XVTHRO=CVQ/UMO
35791       IVTHR=0
35792  3466 CONTINUE
35793       IF(IVTHR.EQ.10)THEN
35794         IREJ=1
35795         IF(ISQ.EQ.3)IREJ=3
35796         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
35797       IPCO=0
35798         RETURN
35799       ENDIF
35800       IVTHR=IVTHR+1
35801       XVTHR=XVTHRO/(201-IVTHR)
35802       UNOPRV=UNON
35803  380  CONTINUE
35804       IF(XVTHR.GT.0.66D0*XDIQT)THEN
35805         IREJ=1
35806         IF(ISQ.EQ.3)IREJ=3
35807         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR  large',
35808      *  XVTHR
35809       IPCO=0
35810         RETURN
35811       ENDIF
35812       IF(DT_RNDM(V).LT.0.5D0)THEN
35813         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35814         XVTQII=XDIQT-XVTQI
35815       ELSE
35816         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35817         XVTQI=XDIQT-XVTQII
35818       ENDIF
35819       IF(IPCO.GE.3)THEN
35820         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
35821       ENDIF
35822 C
35823 C     Prepare 4 momenta of new chains and chain ends
35824 C
35825 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35826 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35827 C    +(4,NTMHKK)
35828 C
35829 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35830 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35831 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35832 C
35833 C     SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35834 C    *              IP1,IP21,IP22,IPP1,IPP2)
35835 C
35836       IF(IPIP.EQ.1)THEN
35837         XSQ1=XSQ
35838         XSAQ1=XSAQ
35839         ISQ1=ISQ
35840         ISAQ1=ISAQ
35841       ELSEIF(IPIP.EQ.2)THEN
35842         XSQ1=XSAQ
35843         XSAQ1=XSQ
35844         ISQ1=ISAQ
35845         ISAQ1=ISQ
35846       ENDIF
35847       IDHKT(1)   =IPP1
35848       ISTHKT(1)  =951
35849       JMOHKT(1,1)=NC2P
35850       JMOHKT(2,1)=0
35851       JDAHKT(1,1)=3+IIGLU1
35852       JDAHKT(2,1)=0
35853 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35854       PHKT(1,1)  =PHKK(1,NC2P)
35855       PHKT(2,1)  =PHKK(2,NC2P)
35856       PHKT(3,1)  =PHKK(3,NC2P)
35857       PHKT(4,1)  =PHKK(4,NC2P)
35858 C     PHKT(5,1)  =PHKK(5,NC2P)
35859       XMIST  =(PHKT(4,1)**2-
35860      * PHKT(3,1)**2-PHKT(2,1)**2-
35861      *PHKT(1,1)**2)
35862       IF(XMIST.GT.0.D0)THEN
35863       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35864      *PHKT(1,1)**2)
35865       ELSE
35866 C     WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
35867       PHKT(5,1)=0.D0
35868       ENDIF
35869       VHKT(1,1)  =VHKK(1,NC2P)
35870       VHKT(2,1)  =VHKK(2,NC2P)
35871       VHKT(3,1)  =VHKK(3,NC2P)
35872       VHKT(4,1)  =VHKK(4,NC2P)
35873       WHKT(1,1)  =WHKK(1,NC2P)
35874       WHKT(2,1)  =WHKK(2,NC2P)
35875       WHKT(3,1)  =WHKK(3,NC2P)
35876       WHKT(4,1)  =WHKK(4,NC2P)
35877 C     Add here IIGLU1 gluons to this chaina
35878       PG1=0.D0
35879       PG2=0.D0
35880       PG3=0.D0
35881       PG4=0.D0
35882       IF(IIGLU1.GE.1)THEN
35883       JJG=NC1P
35884       DO 61 IIG=2,2+IIGLU1-1
35885         KKG=JJG+IIG-1
35886         IDHKT(IIG)   =IDHKK(KKG)
35887         ISTHKT(IIG)  =921
35888         JMOHKT(1,IIG)=KKG
35889         JMOHKT(2,IIG)=0
35890         JDAHKT(1,IIG)=3+IIGLU1
35891         JDAHKT(2,IIG)=0
35892         PHKT(1,IIG)=PHKK(1,KKG)
35893         PG1=PG1+ PHKT(1,IIG)
35894         PHKT(2,IIG)=PHKK(2,KKG)
35895         PG2=PG2+ PHKT(2,IIG)
35896         PHKT(3,IIG)=PHKK(3,KKG)
35897         PG3=PG3+ PHKT(3,IIG)
35898         PHKT(4,IIG)=PHKK(4,KKG)
35899         PG4=PG4+ PHKT(4,IIG)
35900         PHKT(5,IIG)=PHKK(5,KKG)
35901         VHKT(1,IIG)  =VHKK(1,KKG)
35902         VHKT(2,IIG)  =VHKK(2,KKG)
35903         VHKT(3,IIG)  =VHKK(3,KKG)
35904         VHKT(4,IIG)  =VHKK(4,KKG)
35905         WHKT(1,IIG) =WHKK(1,KKG)
35906         WHKT(2,IIG) =WHKK(2,KKG)
35907         WHKT(3,IIG) =WHKK(3,KKG)
35908         WHKT(4,IIG) =WHKK(4,KKG)
35909    61 CONTINUE
35910       ENDIF
35911       IDHKT(2+IIGLU1)   =IP21
35912       ISTHKT(2+IIGLU1)  =952
35913       JMOHKT(1,2+IIGLU1)=NC1T
35914       JMOHKT(2,2+IIGLU1)=0
35915       JDAHKT(1,2+IIGLU1)=3+IIGLU1
35916       JDAHKT(2,2+IIGLU1)=0
35917       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
35918       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
35919       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
35920       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
35921 C     PHKT(5,2)  =PHKK(5,NC1T)
35922       XMIST  =(PHKT(4,2+IIGLU1)**2-
35923      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35924      *PHKT(1,2+IIGLU1)**2)
35925       IF(XMIST.GT.0.D0)THEN
35926       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
35927      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35928      *PHKT(1,2+IIGLU1)**2)
35929       ELSE
35930 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35931         PHKT(5,5+IIGLU1)=0.D0
35932       ENDIF
35933       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
35934       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
35935       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
35936       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
35937       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
35938       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
35939       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
35940       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
35941       IDHKT(3+IIGLU1)   =88888
35942       ISTHKT(3+IIGLU1)  =95
35943       JMOHKT(1,3+IIGLU1)=1
35944       JMOHKT(2,3+IIGLU1)=2+IIGLU1
35945       JDAHKT(1,3+IIGLU1)=0
35946       JDAHKT(2,3+IIGLU1)=0
35947       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35948       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35949       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35950       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35951       XMIST
35952      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35953      *            -PHKT(3,3+IIGLU1)**2)
35954       IF(XMIST.GT.0.D0)THEN
35955       PHKT(5,3+IIGLU1)
35956      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35957      *            -PHKT(3,3+IIGLU1)**2)
35958       ELSE
35959 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35960         PHKT(5,5+IIGLU1)=0.D0
35961       ENDIF
35962       IF(IPIP.GE.2)THEN
35963 C     IF(NUMEV.EQ.-324)THEN
35964 C     WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
35965 C    * JDAHKT(1,1),
35966 C    *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35967       DO 71 IIG=2,2+IIGLU1-1
35968 C     WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35969 C    &             JMOHKT(1,IIG),JMOHKT(2,IIG),
35970 C    * JDAHKT(1,IIG),
35971 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35972    71 CONTINUE
35973 C     WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35974 C    * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35975 C    *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35976 C     WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35977 C    * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35978 C    *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35979       ENDIF
35980       CHAMAL=CHAM1
35981       IF(IPIP.EQ.1)THEN
35982         IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
35983       ELSEIF(IPIP.EQ.2)THEN
35984         IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
35985       ENDIF
35986       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35987 C       IREJ=1
35988         IPCO=0
35989 C       RETURN
35990 C       WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
35991         GO TO 3466
35992       ENDIF
35993       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
35994       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
35995       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
35996       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
35997       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
35998       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
35999       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
36000       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
36001       IF(IPIP.EQ.1)THEN
36002         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
36003       ELSEIF(IPIP.EQ.2)THEN
36004         IDHKT(4+IIGLU1)   =ISAQ1
36005       ENDIF
36006       ISTHKT(4+IIGLU1)  =951
36007       JMOHKT(1,4+IIGLU1)=NC1P
36008       JMOHKT(2,4+IIGLU1)=0
36009       JDAHKT(1,4+IIGLU1)=6+IIGLU1
36010       JDAHKT(2,4+IIGLU1)=0
36011 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36012       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36013       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36014       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36015       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36016 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
36017       XMIST  =(PHKT(4,4+IIGLU1)**2-
36018      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36019      *PHKT(1,4+IIGLU1)**2)
36020       IF(XMIST.GT.0.D0)THEN
36021       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
36022      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36023      *PHKT(1,4+IIGLU1)**2)
36024       ELSE
36025 C     WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
36026       PHKT(5,4+IIGLU1)=0.D0
36027       ENDIF
36028       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
36029       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
36030       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
36031       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
36032       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
36033       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
36034       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
36035       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
36036       IDHKT(5+IIGLU1)   =IP22
36037       ISTHKT(5+IIGLU1)  =952
36038       JMOHKT(1,5+IIGLU1)=NC1T
36039       JMOHKT(2,5+IIGLU1)=0
36040       JDAHKT(1,5+IIGLU1)=6+IIGLU1
36041       JDAHKT(2,5+IIGLU1)=0
36042       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36043       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36044       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36045       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36046 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
36047       XMIST  =(PHKT(4,5+IIGLU1)**2-
36048      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36049      *PHKT(1,5+IIGLU1)**2)
36050       IF(XMIST.GT.0.D0)THEN
36051       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
36052      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36053      *PHKT(1,5+IIGLU1)**2)
36054       ELSE
36055 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36056         PHKT(5,5+IIGLU1)=0.D0
36057       ENDIF
36058       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
36059       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
36060       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
36061       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
36062       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
36063       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
36064       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
36065       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
36066       IDHKT(6+IIGLU1)   =88888
36067       ISTHKT(6+IIGLU1)  =95
36068       JMOHKT(1,6+IIGLU1)=4+IIGLU1
36069       JMOHKT(2,6+IIGLU1)=5+IIGLU1
36070       JDAHKT(1,6+IIGLU1)=0
36071       JDAHKT(2,6+IIGLU1)=0
36072       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36073       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36074       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36075       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36076       XMIST
36077      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36078      *            -PHKT(3,6+IIGLU1)**2)
36079       IF(XMIST.GT.0.D0)THEN
36080       PHKT(5,6+IIGLU1)
36081      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36082      *            -PHKT(3,6+IIGLU1)**2)
36083       ELSE
36084 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36085         PHKT(5,5+IIGLU1)=0.D0
36086       ENDIF
36087 C     IF(IPIP.GE.2)THEN
36088 C     IF(NUMEV.EQ.-324)THEN
36089 C     WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36090 C    * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36091 C    *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36092 C     WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36093 C    * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36094 C    *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36095 C     WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36096 C    * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36097 C    *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36098 C     ENDIF
36099       CHAMAL=CHAM1
36100       IF(IPIP.EQ.1)THEN
36101         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36102       ELSEIF(IPIP.EQ.2)THEN
36103         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36104       ENDIF
36105       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36106 C       IREJ=1
36107         IPCO=0
36108 C       RETURN
36109 C       WRITE(6,*)' MUSQBS1 jump back from chain 6',
36110 C    *  CHAMAL,PHKT(5,6+IIGLU1)
36111         GO TO 3466
36112       ENDIF
36113       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
36114       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
36115       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
36116       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
36117       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
36118       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
36119       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
36120       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
36121 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
36122       IDHKT(7+IIGLU1)   =IP1
36123       ISTHKT(7+IIGLU1)  =951
36124       JMOHKT(1,7+IIGLU1)=NC1P
36125       JMOHKT(2,7+IIGLU1)=0
36126 **NEW
36127 C     JDAHKT(1,7+IIGLU1)=9+IIGLU1
36128       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36129 **
36130       JDAHKT(2,7+IIGLU1)=0
36131       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36132       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36133       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36134       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36135 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
36136       XMIST  =(PHKT(4,7+IIGLU1)**2-
36137      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36138      *PHKT(1,7+IIGLU1)**2)
36139       IF(XMIST.GT.0.D0)THEN
36140       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
36141      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36142      *PHKT(1,7+IIGLU1)**2)
36143       ELSE
36144 C     WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
36145       PHKT(5,7+IIGLU1)=0.D0
36146       ENDIF
36147       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
36148       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
36149       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
36150       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
36151       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
36152       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
36153       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
36154       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
36155 C     Insert here the IIGLU2 gluons
36156       PG1=0.D0
36157       PG2=0.D0
36158       PG3=0.D0
36159       PG4=0.D0
36160       IF(IIGLU2.GE.1)THEN
36161       JJG=NC2P
36162       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36163         KKG=JJG+IIG-7-IIGLU1
36164         IDHKT(IIG)   =IDHKK(KKG)
36165         ISTHKT(IIG)  =921
36166         JMOHKT(1,IIG)=KKG
36167         JMOHKT(2,IIG)=0
36168         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36169         JDAHKT(2,IIG)=0
36170         PHKT(1,IIG)=PHKK(1,KKG)
36171         PG1=PG1+ PHKT(1,IIG)
36172         PHKT(2,IIG)=PHKK(2,KKG)
36173         PG2=PG2+ PHKT(2,IIG)
36174         PHKT(3,IIG)=PHKK(3,KKG)
36175         PG3=PG3+ PHKT(3,IIG)
36176         PHKT(4,IIG)=PHKK(4,KKG)
36177         PG4=PG4+ PHKT(4,IIG)
36178         PHKT(5,IIG)=PHKK(5,KKG)
36179         VHKT(1,IIG)  =VHKK(1,KKG)
36180         VHKT(2,IIG)  =VHKK(2,KKG)
36181         VHKT(3,IIG)  =VHKK(3,KKG)
36182         VHKT(4,IIG)  =VHKK(4,KKG)
36183         WHKT(1,IIG)  =WHKK(1,KKG)
36184         WHKT(2,IIG) =WHKK(2,KKG)
36185         WHKT(3,IIG) =WHKK(3,KKG)
36186         WHKT(4,IIG) =WHKK(4,KKG)
36187    81 CONTINUE
36188       ENDIF
36189       IF(IPIP.EQ.1)THEN
36190         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
36191         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36192         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36193         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36194       ELSEIF(IPIP.EQ.2)THEN
36195         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
36196         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36197         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36198         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36199       ENDIF
36200       ISTHKT(8+IIGLU1+IIGLU2)  =952
36201       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36202       JMOHKT(2,8+IIGLU1+IIGLU2)=0
36203       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36204       JDAHKT(2,8+IIGLU1+IIGLU2)=0
36205       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC2T)+
36206      * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36207       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC2T)+
36208      * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36209       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC2T)+
36210      * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36211       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC2T)+
36212      * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36213 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36214 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36215       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36216 C       IREJ=1
36217 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36218 C    *  ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
36219         IPCO=0
36220 C       RETURN
36221         GO TO 3466
36222       ENDIF
36223 C     PHKT(5,8)  =PHKK(5,NC2T)
36224       XMIST  =(PHKT(4,8+IIGLU1+IIGLU2)**2-
36225      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36226      *PHKT(1,8+IIGLU1+IIGLU2)**2)
36227       IF(XMIST.GT.0.D0)THEN
36228       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36229      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36230      *PHKT(1,8+IIGLU1+IIGLU2)**2)
36231       ELSE
36232 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36233         PHKT(5,5+IIGLU1)=0.D0
36234       ENDIF
36235       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
36236       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
36237       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
36238       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
36239       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
36240       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
36241       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
36242       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
36243       IDHKT(9+IIGLU1+IIGLU2)   =88888
36244       ISTHKT(9+IIGLU1+IIGLU2)  =95
36245       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36246       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36247       JDAHKT(1,9+IIGLU1+IIGLU2)=0
36248       JDAHKT(2,9+IIGLU1+IIGLU2)=0
36249 **NEW
36250 C     PHKT(1,9+IIGLU1+IIGLU2)
36251 C    * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36252 C     PHKT(2,9+IIGLU1+IIGLU2)
36253 C    * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36254 C     PHKT(3,9+IIGLU1+IIGLU2)
36255 C    * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36256 C     PHKT(4,9+IIGLU1+IIGLU2)
36257 C    * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36258       PHKT(1,9+IIGLU1+IIGLU2)
36259      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36260       PHKT(2,9+IIGLU1+IIGLU2)
36261      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36262       PHKT(3,9+IIGLU1+IIGLU2)
36263      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36264       PHKT(4,9+IIGLU1+IIGLU2)
36265      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36266 **
36267       XMIST
36268      * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36269      * -PHKT(2,9+IIGLU1+IIGLU2)**2
36270      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
36271       IF(XMIST.GT.0.D0)THEN
36272       PHKT(5,9+IIGLU1+IIGLU2)
36273      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36274      * -PHKT(2,9+IIGLU1+IIGLU2)**2
36275      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
36276       ELSE
36277 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36278         PHKT(5,5+IIGLU1)=0.D0
36279       ENDIF
36280       IF(IPIP.GE.2)THEN
36281 C     IF(NUMEV.EQ.-324)THEN
36282 C     WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36283 C    * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36284 C    *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36285 C     DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36286 C     WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
36287 C    * JDAHKT(1,IIG),
36288 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36289 C  91 CONTINUE
36290 C     WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36291 C    * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36292 C    *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36293 C    *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36294 C     WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36295 C    * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36296 C    *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36297 C    *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36298       ENDIF
36299       CHAMAL=CHAB1
36300       IF(IPIP.EQ.1)THEN
36301         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36302       ELSEIF(IPIP.EQ.2)THEN
36303         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36304       ENDIF
36305       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36306 C       IREJ=1
36307         IPCO=0
36308 C       RETURN
36309 C       WRITE(6,*)' MUSQBS1 jump back from chain 9',
36310 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
36311         GO TO 3466
36312       ENDIF
36313       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
36314       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
36315       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
36316       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
36317       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
36318       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
36319       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
36320       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
36321 C
36322       IPCO=0
36323       IGCOUN=9+IIGLU1+IIGLU2
36324        RETURN
36325        END
36326
36327 *$ CREATE MGSQBS2.FOR
36328 *COPY MGSQBS2
36329 C
36330 C
36331 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36332       SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36333      *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
36334 C
36335 C                  GSQBS-2 diagram (split target diquark)
36336 C
36337       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36338       SAVE
36339
36340       PARAMETER ( LINP = 10 ,
36341      &            LOUT = 6 ,
36342      &            LDAT = 9 )
36343
36344 * event history
36345
36346       PARAMETER (NMXHKK=200000)
36347
36348       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36349      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36350      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36351
36352 * extended event history
36353       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36354      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36355      &                IHIST(2,NMXHKK)
36356
36357 * Lorentz-parameters of the current interaction
36358       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36359      &                UMO,PPCM,EPROJ,PPROJ
36360
36361 * diquark-breaking mechanism
36362       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36363
36364 C
36365       PARAMETER (NTMHKK= 300)
36366       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36367      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36368      +(4,NTMHKK)
36369
36370 *KEEP,XSEADI.
36371       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36372      +SSMIMQ,VVMTHR
36373 *KEEP,DPRIN.
36374       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36375 C
36376 C                  GSQBS-2 diagram (split target diquark)
36377 C
36378 C
36379 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
36380 C     Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
36381 C
36382 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
36383 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36384 C
36385 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36386 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36387 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36388 C
36389 C
36390 C
36391 C       Put new chains into COMMON /HKKTMP/
36392 C
36393       IIGLU1=NC1T-NC1P-1
36394       IIGLU2=NC2T-NC2P-1
36395       IGCOUN=0
36396 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36397       CVQ=1.D0
36398       IREJ=0
36399 C     IF(IPIP.EQ.2)THEN
36400 C     WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
36401 C    *             'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
36402 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36403 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
36404 C     ENDIF
36405 C
36406 C
36407 C
36408 C     determine x-values of NC1T diquark
36409       XDIQT=PHKK(4,NC1T)*2.D0/UMO
36410       XVQP=PHKK(4,NC1P)*2.D0/UMO
36411 C
36412 C     determine x-values of sea quark pair
36413 C
36414       IPCO=1
36415       ICOU=0
36416  2234 CONTINUE
36417       ICOU=ICOU+1
36418       IF(ICOU.GE.500)THEN
36419         IREJ=1
36420         IF(ISQ.EQ.3)IREJ=3
36421         IF(IPCO.GE.3)
36422      &     WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
36423         IPCO=0
36424         RETURN
36425       ENDIF
36426       IF(IPCO.GE.3)
36427      &     WRITE(LOUT,*)'MGSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
36428      * UMO, XDIQT,XVQP
36429       XSQ=0.D0
36430       XSAQ=0.D0
36431 **NEW
36432 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
36433       IF (IPIP.EQ.1) THEN
36434          XQMAX  = XDIQT/2.0D0
36435          XAQMAX = 2.D0*XVQP/3.0D0
36436       ELSE
36437          XQMAX  = 2.D0*XVQP/3.0D0
36438          XAQMAX = XDIQT/2.0D0
36439       ENDIF
36440       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
36441       ISAQ = 6+ISQ
36442 C     write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
36443 **
36444         IF(IPCO.GE.3)
36445      &     WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36446       IF(IREJ.GE.1)THEN
36447         IF(IPCO.GE.3)
36448      &     WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36449         IPCO=0
36450         RETURN
36451       ENDIF
36452       IF(IPIP.EQ.1)THEN
36453         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36454       ELSEIF(IPIP.EQ.2)THEN
36455         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36456       ENDIF
36457       IF(IPCO.GE.3)THEN
36458         WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
36459      &  XDIQT,XVQP,XSQ,XSAQ
36460       ENDIF
36461 C
36462 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
36463 C
36464 C     XSQ=0.D0
36465       IF(IPIP.EQ.1)THEN
36466         XDIQT=XDIQT-XSQ
36467         XVQP =XVQP -XSAQ
36468       ELSEIF(IPIP.EQ.2)THEN
36469         XDIQT=XDIQT-XSAQ
36470         XVQP =XVQP -XSQ
36471       ENDIF
36472       IF(IPCO.GE.3)
36473      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
36474 C
36475 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36476 C
36477       XVTHRO=CVQ/UMO
36478       IVTHR=0
36479  3466 CONTINUE
36480       IF(IVTHR.EQ.10)THEN
36481         IREJ=1
36482         IF(ISQ.EQ.3)IREJ=3
36483         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
36484         IPCO=0
36485         RETURN
36486       ENDIF
36487       IVTHR=IVTHR+1
36488       XVTHR=XVTHRO/(201-IVTHR)
36489       UNOPRV=UNON
36490  380  CONTINUE
36491       IF(XVTHR.GT.0.66D0*XDIQT)THEN
36492         IREJ=1
36493         IF(ISQ.EQ.3)IREJ=3
36494         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR  large',
36495      *  XVTHR
36496         IPCO=0
36497         RETURN
36498       ENDIF
36499       IF(DT_RNDM(V).LT.0.5D0)THEN
36500         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36501         XVTQII=XDIQT-XVTQI
36502       ELSE
36503         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36504         XVTQI=XDIQT-XVTQII
36505       ENDIF
36506       IF(IPCO.GE.3)THEN
36507         WRITE(LOUT,'(A,2E12.4)')'  MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
36508       ENDIF
36509 C
36510 C     Prepare 4 momenta of new chains and chain ends
36511 C
36512 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36513 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36514 C    +(4,NTMHKK)
36515 C
36516 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36517 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36518 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36519 C
36520 C     SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36521 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
36522 C
36523       IF(IPIP.EQ.1)THEN
36524         XSQ1=XSQ
36525         XSAQ1=XSAQ
36526         ISQ1=ISQ
36527         ISAQ1=ISAQ
36528       ELSEIF(IPIP.EQ.2)THEN
36529         XSQ1=XSAQ
36530         XSAQ1=XSQ
36531         ISQ1=ISAQ
36532         ISAQ1=ISQ
36533       ENDIF
36534       KK11=IP21
36535 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36536       KK21=IPP11
36537       KK22=IPP12
36538       XGIVE=0.D0
36539       IF(IPIP.EQ.1)THEN
36540         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
36541       ELSEIF(IPIP.EQ.2)THEN
36542         IDHKT(4+IIGLU1)   =ISAQ1
36543       ENDIF
36544       ISTHKT(4+IIGLU1)  =961
36545       JMOHKT(1,4+IIGLU1)=NC1P
36546       JMOHKT(2,4+IIGLU1)=0
36547       JDAHKT(1,4+IIGLU1)=6+IIGLU1
36548       JDAHKT(2,4+IIGLU1)=0
36549 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36550       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36551       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36552       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36553       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36554 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
36555       XXMIST=(PHKT(4,4+IIGLU1)**2-
36556      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36557      *PHKT(1,4+IIGLU1)**2)
36558       IF(XXMIST.GT.0.D0)THEN
36559         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
36560       ELSE
36561         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36562         XXMIST=ABS(XXMIST)
36563         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
36564       ENDIF
36565       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
36566       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
36567       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
36568       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
36569       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
36570       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
36571       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
36572       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
36573       IDHKT(5+IIGLU1)   =IP22
36574       ISTHKT(5+IIGLU1)  =962
36575       JMOHKT(1,5+IIGLU1)=NC1T
36576       JMOHKT(2,5+IIGLU1)=0
36577       JDAHKT(1,5+IIGLU1)=6+IIGLU1
36578       JDAHKT(2,5+IIGLU1)=0
36579       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36580       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36581       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36582       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36583 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
36584       XXMIST=(PHKT(4,5+IIGLU1)**2-
36585      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36586      *PHKT(1,5+IIGLU1)**2)
36587       IF(XXMIST.GT.0.D0)THEN
36588         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
36589       ELSE
36590         WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
36591         XXMIST=ABS(XXMIST)
36592         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
36593       ENDIF
36594       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
36595       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
36596       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
36597       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
36598       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
36599       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
36600       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
36601       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
36602       IDHKT(6+IIGLU1)   =88888
36603       ISTHKT(6+IIGLU1)  =96
36604       JMOHKT(1,6+IIGLU1)=4+IIGLU1
36605       JMOHKT(2,6+IIGLU1)=5+IIGLU1
36606       JDAHKT(1,6+IIGLU1)=0
36607       JDAHKT(2,6+IIGLU1)=0
36608       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36609       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36610       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36611       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36612       PHKT(5,6+IIGLU1)
36613      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36614      *            -PHKT(3,6+IIGLU1)**2)
36615       CHAMAL=CHAM1
36616       IF(IPIP.EQ.1)THEN
36617         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36618       ELSEIF(IPIP.EQ.2)THEN
36619         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36620       ENDIF
36621 C---------------------------------------------------
36622       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36623         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
36624 C                    we drop chain 6 and give the energy to chain 3
36625           IDHKT(6+IIGLU1)=22888
36626           XGIVE=1.D0
36627 C         WRITE(6,*)' drop chain 6 xgive=1'
36628           GO TO 7788
36629         ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
36630 C                    we drop chain 6 and give the energy to chain 3
36631 C                    and change KK11 to IDHKT(5)
36632           IDHKT(6+IIGLU1)=22888
36633           XGIVE=1.D0
36634 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
36635           KK11=IDHKT(5+IIGLU1)
36636           GO TO 7788
36637         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
36638 C                    we drop chain 6 and give the energy to chain 3
36639 C                    and change KK21 to IDHKT(5+IIGLU1)
36640 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36641           IDHKT(6+IIGLU1)=22888
36642           XGIVE=1.D0
36643 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
36644           KK21=IDHKT(5+IIGLU1)
36645           GO TO 7788
36646         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
36647 C                    we drop chain 6 and give the energy to chain 3
36648 C                    and change KK22 to IDHKT(5)
36649 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36650           IDHKT(6+IIGLU1)=22888
36651           XGIVE=1.D0
36652 C          WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
36653           KK22=IDHKT(5+IIGLU1)
36654           GO TO 7788
36655         ENDIF
36656 C       IREJ=1
36657         IPCO=0
36658 C       RETURN
36659         GO TO 3466
36660       ENDIF
36661  7788 CONTINUE
36662 C---------------------------------------------------
36663       IF(IPIP.GE.3)THEN
36664       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36665      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36666      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36667       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36668      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36669      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36670       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36671      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36672      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36673       ENDIF
36674       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
36675       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
36676       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
36677       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
36678       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
36679       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
36680       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
36681       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
36682 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36683       IF(IPIP.EQ.1)THEN
36684         IDHKT(1)   =1000*KK21+100*KK22+3
36685         IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
36686         IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
36687         IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
36688       ELSEIF(IPIP.EQ.2)THEN
36689         IDHKT(1)   =1000*KK21+100*KK22-3
36690         IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
36691         IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
36692         IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
36693       ENDIF
36694       ISTHKT(1)  =961
36695       JMOHKT(1,1)=NC2P
36696       JMOHKT(2,1)=0
36697       JDAHKT(1,1)=3+IIGLU1
36698       JDAHKT(2,1)=0
36699 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36700       PHKT(1,1)  =PHKK(1,NC2P)
36701      *+XGIVE*PHKT(1,4+IIGLU1)
36702       PHKT(2,1)  =PHKK(2,NC2P)
36703      *+XGIVE*PHKT(2,4+IIGLU1)
36704       PHKT(3,1)  =PHKK(3,NC2P)
36705      *+XGIVE*PHKT(3,4+IIGLU1)
36706       PHKT(4,1)  =PHKK(4,NC2P)
36707      *+XGIVE*PHKT(4,4+IIGLU1)
36708 C     PHKT(5,1)  =PHKK(5,NC2P)
36709       XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36710      *PHKT(1,1)**2
36711       IF(XXMIST.GT.0.D0)THEN
36712         PHKT(5,1)  =SQRT(XXMIST)
36713       ELSE
36714         WRITE(LOUT,*)'MGSQBS2',XXMIST
36715         XXMIST=ABS(XXMIST)
36716         PHKT(5,1)  =SQRT(XXMIST)
36717       ENDIF
36718       VHKT(1,1)  =VHKK(1,NC2P)
36719       VHKT(2,1)  =VHKK(2,NC2P)
36720       VHKT(3,1)  =VHKK(3,NC2P)
36721       VHKT(4,1)  =VHKK(4,NC2P)
36722       WHKT(1,1)  =WHKK(1,NC2P)
36723       WHKT(2,1)  =WHKK(2,NC2P)
36724       WHKT(3,1)  =WHKK(3,NC2P)
36725       WHKT(4,1)  =WHKK(4,NC2P)
36726 C     Add here IIGLU1 gluons to this chaina
36727       PG1=0.D0
36728       PG2=0.D0
36729       PG3=0.D0
36730       PG4=0.D0
36731       IF(IIGLU1.GE.1)THEN
36732       JJG=NC1P
36733       DO 61 IIG=2,2+IIGLU1-1
36734         KKG=JJG+IIG-1
36735         IDHKT(IIG)   =IDHKK(KKG)
36736         ISTHKT(IIG)  =921
36737         JMOHKT(1,IIG)=KKG
36738         JMOHKT(2,IIG)=0
36739         JDAHKT(1,IIG)=3+IIGLU1
36740         JDAHKT(2,IIG)=0
36741         PHKT(1,IIG)=PHKK(1,KKG)
36742         PG1=PG1+ PHKT(1,IIG)
36743         PHKT(2,IIG)=PHKK(2,KKG)
36744         PG2=PG2+ PHKT(2,IIG)
36745         PHKT(3,IIG)=PHKK(3,KKG)
36746         PG3=PG3+ PHKT(3,IIG)
36747         PHKT(4,IIG)=PHKK(4,KKG)
36748         PG4=PG4+ PHKT(4,IIG)
36749         PHKT(5,IIG)=PHKK(5,KKG)
36750         VHKT(1,IIG)  =VHKK(1,KKG)
36751         VHKT(2,IIG)  =VHKK(2,KKG)
36752         VHKT(3,IIG)  =VHKK(3,KKG)
36753         VHKT(4,IIG)  =VHKK(4,KKG)
36754         WHKT(1,IIG)  =WHKK(1,KKG)
36755         WHKT(2,IIG)  =WHKK(2,KKG)
36756         WHKT(3,IIG)  =WHKK(3,KKG)
36757         WHKT(4,IIG)  =WHKK(4,KKG)
36758    61 CONTINUE
36759       ENDIF
36760 C     IDHKT(2)   =IP21
36761       IDHKT(2+IIGLU1)   =KK11
36762       ISTHKT(2+IIGLU1)  =962
36763       JMOHKT(1,2+IIGLU1)=NC1T
36764       JMOHKT(2,2+IIGLU1)=0
36765       JDAHKT(1,2+IIGLU1)=3+IIGLU1
36766       JDAHKT(2,2+IIGLU1)=0
36767       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
36768 C    * +0.5D0*PHKK(1,NC2T)
36769      *+XGIVE*PHKT(1,5+IIGLU1)
36770       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
36771 C    *+0.5D0*PHKK(2,NC2T)
36772      *+XGIVE*PHKT(2,5+IIGLU1)
36773       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
36774 C    *+0.5D0*PHKK(3,NC2T)
36775      *+XGIVE*PHKT(3,5+IIGLU1)
36776       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
36777 C    *+0.5D0*PHKK(4,NC2T)
36778      *+XGIVE*PHKT(4,5+IIGLU1)
36779 C     PHKT(5,2)  =PHKK(5,NC1T)
36780       XXMIST=(PHKT(4,2+IIGLU1)**2-
36781      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36782      *PHKT(1,2+IIGLU1)**2)
36783       IF(XXMIST.GT.0.D0)THEN
36784         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
36785       ELSE
36786         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36787         XXMIST=ABS(XXMIST)
36788         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
36789       ENDIF
36790       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
36791       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
36792       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
36793       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
36794       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
36795       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
36796       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
36797       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
36798       IDHKT(3+IIGLU1)   =88888
36799       ISTHKT(3+IIGLU1)  =96
36800       JMOHKT(1,3+IIGLU1)=1
36801       JMOHKT(2,3+IIGLU1)=2+IIGLU1
36802       JDAHKT(1,3+IIGLU1)=0
36803       JDAHKT(2,3+IIGLU1)=0
36804       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
36805       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
36806       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
36807       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
36808       PHKT(5,3+IIGLU1)
36809      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
36810      *            -PHKT(3,3+IIGLU1)**2)
36811       IF(IPIP.EQ.3)THEN
36812       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
36813      * JDAHKT(1,1),
36814      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
36815       DO 71 IIG=2,2+IIGLU1-1
36816       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36817      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
36818      * JDAHKT(1,IIG),
36819      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36820    71 CONTINUE
36821       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
36822      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
36823      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
36824       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
36825      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
36826      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
36827       ENDIF
36828       CHAMAL=CHAB1
36829       IF(IPIP.EQ.1)THEN
36830         IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
36831       ELSEIF(IPIP.EQ.2)THEN
36832         IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
36833       ENDIF
36834       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
36835 C       IREJ=1
36836         IPCO=0
36837 C       RETURN
36838         GO TO 3466
36839       ENDIF
36840       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
36841       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
36842       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
36843       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
36844       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
36845       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
36846       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
36847       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
36848 C     IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+1
36849       IDHKT(7+IIGLU1)   =IP1
36850       ISTHKT(7+IIGLU1)  =961
36851       JMOHKT(1,7+IIGLU1)=NC1P
36852       JMOHKT(2,7+IIGLU1)=0
36853       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36854       JDAHKT(2,7+IIGLU1)=0
36855       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36856       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36857       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36858       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36859 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
36860       XXMIST=(PHKT(4,7+IIGLU1)**2-
36861      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36862      *PHKT(1,7+IIGLU1)**2)
36863       IF(XXMIST.GT.0.D0)THEN
36864         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
36865       ELSE
36866         WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
36867         XXMIST=ABS(XXMIST)
36868         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
36869       ENDIF
36870       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
36871       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
36872       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
36873       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
36874       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
36875       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
36876       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
36877       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
36878 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
36879 C     Insert here the IIGLU2 gluons
36880       PG1=0.D0
36881       PG2=0.D0
36882       PG3=0.D0
36883       PG4=0.D0
36884       IF(IIGLU2.GE.1)THEN
36885       JJG=NC2P
36886       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36887         KKG=JJG+IIG-7-IIGLU1
36888         IDHKT(IIG)   =IDHKK(KKG)
36889         ISTHKT(IIG)  =921
36890         JMOHKT(1,IIG)=KKG
36891         JMOHKT(2,IIG)=0
36892         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36893         JDAHKT(2,IIG)=0
36894         PHKT(1,IIG)=PHKK(1,KKG)
36895         PG1=PG1+ PHKT(1,IIG)
36896         PHKT(2,IIG)=PHKK(2,KKG)
36897         PG2=PG2+ PHKT(2,IIG)
36898         PHKT(3,IIG)=PHKK(3,KKG)
36899         PG3=PG3+ PHKT(3,IIG)
36900         PHKT(4,IIG)=PHKK(4,KKG)
36901         PG4=PG4+ PHKT(4,IIG)
36902         PHKT(5,IIG)=PHKK(5,KKG)
36903         VHKT(1,IIG)  =VHKK(1,KKG)
36904         VHKT(2,IIG)  =VHKK(2,KKG)
36905         VHKT(3,IIG)  =VHKK(3,KKG)
36906         VHKT(4,IIG)  =VHKK(4,KKG)
36907         WHKT(1,IIG)  =WHKK(1,KKG)
36908         WHKT(2,IIG)  =WHKK(2,KKG)
36909         WHKT(3,IIG)  =WHKK(3,KKG)
36910         WHKT(4,IIG)  =WHKK(4,KKG)
36911    81 CONTINUE
36912       ENDIF
36913       IF(IPIP.EQ.1)THEN
36914         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
36915         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36916         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36917         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36918       ELSEIF(IPIP.EQ.2)THEN
36919 **NEW
36920 C       IDHKT(8)   =1000*IPP2+100*(-ISQ1+6)-3
36921         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
36922 **
36923         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36924         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36925         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36926       ENDIF
36927       ISTHKT(8+IIGLU1+IIGLU2)  =962
36928       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36929       JMOHKT(2,8+IIGLU1+IIGLU2)=0
36930       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36931       JDAHKT(2,8+IIGLU1+IIGLU2)=0
36932 C     PHKT(1,8)  =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
36933 C     PHKT(2,8)  =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
36934 C     PHKT(3,8)  =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
36935 C     PHKT(4,8)  =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
36936       PHKT(1,8+IIGLU1+IIGLU2)  =
36937      * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36938       PHKT(2,8+IIGLU1+IIGLU2)  =
36939      * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36940       PHKT(3,8+IIGLU1+IIGLU2)  =
36941      * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36942       PHKT(4,8+IIGLU1+IIGLU2)  =
36943      * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36944 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36945 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36946       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36947 C       IREJ=1
36948 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36949         IPCO=0
36950 C       RETURN
36951         GO TO 3466
36952       ENDIF
36953 C     PHKT(5,8)  =PHKK(5,NC2T)
36954       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36955      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36956      *PHKT(1,8+IIGLU1+IIGLU2)**2)
36957       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
36958       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
36959       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
36960       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
36961       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
36962       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
36963       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
36964       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
36965       IDHKT(9+IIGLU1+IIGLU2)   =88888
36966       ISTHKT(9+IIGLU1+IIGLU2)  =96
36967       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36968       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36969       JDAHKT(1,9+IIGLU1+IIGLU2)=0
36970       JDAHKT(2,9+IIGLU1+IIGLU2)=0
36971       PHKT(1,9+IIGLU1+IIGLU2)
36972      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36973       PHKT(2,9+IIGLU1+IIGLU2)
36974      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36975       PHKT(3,9+IIGLU1+IIGLU2)
36976      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36977       PHKT(4,9+IIGLU1+IIGLU2)
36978      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36979       PHKT(5,9+IIGLU1+IIGLU2)
36980      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
36981      * PHKT(2,9+IIGLU1+IIGLU2)**2
36982      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
36983       IF(IPIP.GE.3)THEN
36984       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36985      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36986      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36987       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36988       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36989      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
36990      * JDAHKT(1,IIG),
36991      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36992    91 CONTINUE
36993       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36994      * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36995      *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36996      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36997       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36998      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36999      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37000      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37001       ENDIF
37002       CHAMAL=CHAB1
37003       IF(IPIP.EQ.1)THEN
37004         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37005       ELSEIF(IPIP.EQ.2)THEN
37006         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37007       ENDIF
37008       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37009 C       IREJ=1
37010         IPCO=0
37011 C       RETURN
37012         GO TO 3466
37013       ENDIF
37014       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
37015       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
37016       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
37017       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
37018       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
37019       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
37020       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
37021       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
37022 C
37023       IPCO=0
37024       IGCOUN=9+IIGLU1+IIGLU2
37025        RETURN
37026        END
37027
37028 *$ CREATE MUSQBS1.FOR
37029 *COPY MUSQBS1
37030 C
37031 C
37032 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37033       SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37034      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
37035 C
37036 C                  USQBS-1 diagram (split projectile diquark)
37037 C
37038       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37039       SAVE
37040
37041       PARAMETER ( LINP = 10 ,
37042      &            LOUT = 6 ,
37043      &            LDAT = 9 )
37044
37045 * event history
37046
37047       PARAMETER (NMXHKK=200000)
37048
37049       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37050      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37051      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37052
37053 * extended event history
37054       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37055      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37056      &                IHIST(2,NMXHKK)
37057
37058 * Lorentz-parameters of the current interaction
37059       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37060      &                UMO,PPCM,EPROJ,PPROJ
37061
37062 * diquark-breaking mechanism
37063       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37064
37065 C
37066       PARAMETER (NTMHKK= 300)
37067       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37068      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37069      +(4,NTMHKK)
37070 *KEEP,XSEADI.
37071       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37072      +SSMIMQ,VVMTHR
37073 *KEEP,DPRIN.
37074       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37075       COMMON /EVFLAG/ NUMEV
37076 C
37077 C                  USQBS-1 diagram (split projectile diquark)
37078 C
37079 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37080 C     Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
37081 C
37082 C     Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
37083 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37084 C
37085 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37086 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37087 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37088 C
37089 C       Put new chains into COMMON /HKKTMP/
37090 C
37091       IIGLU1=NC1T-NC1P-1
37092       IIGLU2=NC2T-NC2P-1
37093       IGCOUN=0
37094 C     WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
37095       CVQ=1.D0
37096       IREJ=0
37097       IF(IPIP.EQ.3)THEN
37098 C     IF(NUMEV.EQ.-324)THEN
37099       WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37100      *             ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
37101      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37102      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
37103       ENDIF
37104 C
37105 C
37106 C
37107 C     determine x-values of NC1P diquark
37108       XDIQP=PHKK(4,NC1P)*2.D0/UMO
37109       XVQT=PHKK(4,NC1T)*2.D0/UMO
37110 C
37111 C     determine x-values of sea quark pair
37112 C
37113       IPCO=1
37114       ICOU=0
37115  2234 CONTINUE
37116       ICOU=ICOU+1
37117       IF(ICOU.GE.500)THEN
37118         IREJ=1
37119         IF(ISQ.EQ.3)IREJ=3
37120         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
37121         IPCO=0
37122         RETURN
37123       ENDIF
37124       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
37125      * UMO, XDIQP,XVQT
37126       XSQ=0.D0
37127       XSAQ=0.D0
37128 **NEW
37129 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37130       IF (IPIP.EQ.1) THEN
37131          XQMAX  = XDIQP/2.0D0
37132          XAQMAX = 2.D0*XVQT/3.0D0
37133       ELSE
37134          XQMAX  = 2.D0*XVQT/3.0D0
37135          XAQMAX = XDIQP/2.0D0
37136       ENDIF
37137       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37138       ISAQ = 6+ISQ
37139 C     write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37140 **
37141       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37142       IF(IREJ.GE.1)THEN
37143         IF(IPCO.GE.3)
37144      &     WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37145         IPCO=0
37146         RETURN
37147       ENDIF
37148       IF(IPIP.EQ.1)THEN
37149         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37150       ELSEIF(IPIP.EQ.2)THEN
37151         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37152       ENDIF
37153       IF(IPCO.GE.3)THEN
37154         WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37155      &  XDIQP,XVQT,XSQ,XSAQ
37156       ENDIF
37157 C
37158 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
37159 C
37160 C     XSQ=0.D0
37161       IF(IPIP.EQ.1)THEN
37162         XDIQP=XDIQP-XSQ
37163         XVQT =XVQT -XSAQ
37164       ELSEIF(IPIP.EQ.2)THEN
37165         XDIQP=XDIQP-XSAQ
37166         XVQT =XVQT -XSQ
37167       ENDIF
37168       IF(IPCO.GE.3)
37169      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37170 C
37171 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37172 C
37173       XVTHRO=CVQ/UMO
37174       IVTHR=0
37175  3466 CONTINUE
37176       IF(IVTHR.EQ.10)THEN
37177         IREJ=1
37178         IF(ISQ.EQ.3)IREJ=3
37179         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
37180         IPCO=0
37181         RETURN
37182       ENDIF
37183       IVTHR=IVTHR+1
37184       XVTHR=XVTHRO/(201-IVTHR)
37185       UNOPRV=UNON
37186  380  CONTINUE
37187       IF(XVTHR.GT.0.66D0*XDIQP)THEN
37188         IREJ=1
37189         IF(ISQ.EQ.3)IREJ=3
37190         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR  large',
37191      *  XVTHR
37192         IPCO=0
37193         RETURN
37194       ENDIF
37195       IF(DT_RNDM(V).LT.0.5D0)THEN
37196         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37197         XVPQII=XDIQP-XVPQI
37198       ELSE
37199         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37200         XVPQI=XDIQP-XVPQII
37201       ENDIF
37202       IF(IPCO.GE.3)THEN
37203         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
37204       ENDIF
37205 C
37206 C     Prepare 4 momenta of new chains and chain ends
37207 C
37208 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37209 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37210 C    +(4,NTMHKK)
37211 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37212 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37213 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37214       IF(IPIP.EQ.1)THEN
37215         XSQ1=XSQ
37216         XSAQ1=XSAQ
37217         ISQ1=ISQ
37218         ISAQ1=ISAQ
37219       ELSEIF(IPIP.EQ.2)THEN
37220         XSQ1=XSAQ
37221         XSAQ1=XSQ
37222         ISQ1=ISAQ
37223         ISAQ1=ISQ
37224       ENDIF
37225       IDHKT(1)   =IP11
37226       ISTHKT(1)  =931
37227       JMOHKT(1,1)=NC1P
37228       JMOHKT(2,1)=0
37229       JDAHKT(1,1)=3+IIGLU1
37230       JDAHKT(2,1)=0
37231 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37232       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
37233       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
37234       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
37235       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
37236 C     PHKT(5,1)  =PHKK(5,NC1P)
37237       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37238      *PHKT(1,1)**2)
37239       IF(XMIST.GE.0.D0)THEN
37240       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37241      *PHKT(1,1)**2)
37242       ELSE
37243 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37244        PHKT(5,1)=0.D0
37245       ENDIF
37246       VHKT(1,1)  =VHKK(1,NC1P)
37247       VHKT(2,1)  =VHKK(2,NC1P)
37248       VHKT(3,1)  =VHKK(3,NC1P)
37249       VHKT(4,1)  =VHKK(4,NC1P)
37250       WHKT(1,1)  =WHKK(1,NC1P)
37251       WHKT(2,1)  =WHKK(2,NC1P)
37252       WHKT(3,1)  =WHKK(3,NC1P)
37253       WHKT(4,1)  =WHKK(4,NC1P)
37254 C     Add here IIGLU1 gluons to this chaina
37255       PG1=0.D0
37256       PG2=0.D0
37257       PG3=0.D0
37258       PG4=0.D0
37259       IF(IIGLU1.GE.1)THEN
37260       JJG=NC1P
37261       DO 61 IIG=2,2+IIGLU1-1
37262         KKG=JJG+IIG-1
37263         IDHKT(IIG)   =IDHKK(KKG)
37264         ISTHKT(IIG)  =921
37265         JMOHKT(1,IIG)=KKG
37266         JMOHKT(2,IIG)=0
37267         JDAHKT(1,IIG)=3+IIGLU1
37268         JDAHKT(2,IIG)=0
37269         PHKT(1,IIG)=PHKK(1,KKG)
37270         PG1=PG1+ PHKT(1,IIG)
37271         PHKT(2,IIG)=PHKK(2,KKG)
37272         PG2=PG2+ PHKT(2,IIG)
37273         PHKT(3,IIG)=PHKK(3,KKG)
37274         PG3=PG3+ PHKT(3,IIG)
37275         PHKT(4,IIG)=PHKK(4,KKG)
37276         PG4=PG4+ PHKT(4,IIG)
37277         PHKT(5,IIG)=PHKK(5,KKG)
37278         VHKT(1,IIG)  =VHKK(1,KKG)
37279         VHKT(2,IIG)  =VHKK(2,KKG)
37280         VHKT(3,IIG)  =VHKK(3,KKG)
37281         VHKT(4,IIG)  =VHKK(4,KKG)
37282         WHKT(1,IIG) =WHKK(1,KKG)
37283         WHKT(2,IIG) =WHKK(2,KKG)
37284         WHKT(3,IIG) =WHKK(3,KKG)
37285         WHKT(4,IIG) =WHKK(4,KKG)
37286    61 CONTINUE
37287       ENDIF
37288       IDHKT(2+IIGLU1)   =IPP2
37289       ISTHKT(2+IIGLU1)  =932
37290       JMOHKT(1,2+IIGLU1)=NC2T
37291       JMOHKT(2,2+IIGLU1)=0
37292       JDAHKT(1,2+IIGLU1)=3+IIGLU1
37293       JDAHKT(2,2+IIGLU1)=0
37294       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
37295       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
37296       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
37297       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
37298 C     PHKT(5,2+IIGLU1)  =PHKK(5,NC2T)
37299       XMIST=(PHKT(4,2+IIGLU1)**2-
37300      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37301      *PHKT(1,2+IIGLU1)**2)
37302       IF(XMIST.GT.0.D0)THEN
37303       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
37304      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37305      *PHKT(1,2+IIGLU1)**2)
37306       ELSE
37307 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37308         PHKT(5,2+IIGLU1)=0.D0
37309       ENDIF
37310       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
37311       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
37312       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
37313       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
37314       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
37315       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
37316       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
37317       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
37318       IDHKT(3+IIGLU1)   =88888
37319       ISTHKT(3+IIGLU1)  =94
37320       JMOHKT(1,3+IIGLU1)=1
37321       JMOHKT(2,3+IIGLU1)=2+IIGLU1
37322       JDAHKT(1,3+IIGLU1)=0
37323       JDAHKT(2,3+IIGLU1)=0
37324       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37325       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37326       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37327       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37328       XMIST
37329      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37330      *            -PHKT(3,3+IIGLU1)**2)
37331       IF(XMIST.GE.0.D0)THEN
37332       PHKT(5,3+IIGLU1)
37333      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37334      *            -PHKT(3,3+IIGLU1)**2)
37335       ELSE
37336 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37337        PHKT(5,1)=0.D0
37338       ENDIF
37339       IF(IPIP.GE.3)THEN
37340 C     IF(NUMEV.EQ.-324)THEN
37341       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
37342      * JMOHKT(2,1),JDAHKT(1,1),
37343      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37344       DO 71 IIG=2,2+IIGLU1-1
37345       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37346      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
37347      * JDAHKT(1,IIG),
37348      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37349    71 CONTINUE
37350       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37351      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37352      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37353       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37354      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37355      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37356       ENDIF
37357       CHAMAL=CHAM1
37358       IF(IPIP.EQ.1)THEN
37359         IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
37360       ELSEIF(IPIP.EQ.2)THEN
37361         IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
37362       ENDIF
37363       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37364 C       IREJ=1
37365         IPCO=0
37366 C       RETURN
37367 C       WRITE(6,*)' MUSQBS1 jump back from chain 3'
37368         GO TO 3466
37369       ENDIF
37370       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
37371       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
37372       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
37373       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
37374       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
37375       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
37376       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
37377       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
37378       IDHKT(4+IIGLU1)   =IP12
37379       ISTHKT(4+IIGLU1)  =931
37380       JMOHKT(1,4+IIGLU1)=NC1P
37381       JMOHKT(2,4+IIGLU1)=0
37382       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37383       JDAHKT(2,4+IIGLU1)=0
37384 C   create  chain   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37385       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37386       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37387       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37388       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37389 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37390       XMIST  =(PHKT(4,4+IIGLU1)**2-
37391      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37392      *PHKT(1,4+IIGLU1)**2)
37393       IF(XMIST.GT.0.D0)THEN
37394       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
37395      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37396      *PHKT(1,4+IIGLU1)**2)
37397       ELSE
37398 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37399         PHKT(5,4+IIGLU1)=0.D0
37400       ENDIF
37401       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37402       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37403       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37404       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37405       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37406       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37407       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37408       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37409       IF(IPIP.EQ.1)THEN
37410         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
37411       ELSEIF(IPIP.EQ.2)THEN
37412         IDHKT(5+IIGLU1)   =ISAQ1
37413       ENDIF
37414       ISTHKT(5+IIGLU1)  =932
37415       JMOHKT(1,5+IIGLU1)=NC1T
37416       JMOHKT(2,5+IIGLU1)=0
37417       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37418       JDAHKT(2,5+IIGLU1)=0
37419       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37420       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37421       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37422       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37423 C     IF( PHKT(4,5).EQ.0.D0)THEN
37424 C       IREJ=1
37425 CIPCO=0
37426 CRETURN
37427 C     ENDIF
37428 C     PHKT(5,5)  =PHKK(5,NC1T)
37429       XMIST=(PHKT(4,5+IIGLU1)**2-
37430      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37431      *PHKT(1,5+IIGLU1)**2)
37432       IF(XMIST.GT.0.D0)THEN
37433       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
37434      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37435      *PHKT(1,5+IIGLU1)**2)
37436       ELSE
37437 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37438         PHKT(5,5+IIGLU1)=0.D0
37439       ENDIF
37440       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37441       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37442       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37443       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37444       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37445       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37446       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37447       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37448       IDHKT(6+IIGLU1)   =88888
37449       ISTHKT(6+IIGLU1)  =94
37450       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37451       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37452       JDAHKT(1,6+IIGLU1)=0
37453       JDAHKT(2,6+IIGLU1)=0
37454       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37455       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37456       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37457       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37458       XMIST
37459      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37460      *            -PHKT(3,6+IIGLU1)**2)
37461       IF(XMIST.GE.0.D0)THEN
37462       PHKT(5,6+IIGLU1)
37463      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37464      *            -PHKT(3,6+IIGLU1)**2)
37465       ELSE
37466 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37467        PHKT(5,1)=0.D0
37468       ENDIF
37469 C     IF(IPIP.EQ.3)THEN
37470       CHAMAL=CHAM1
37471       IF(IPIP.EQ.1)THEN
37472         IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37473       ELSEIF(IPIP.EQ.2)THEN
37474         IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37475       ENDIF
37476       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37477 C       IREJ=1
37478         IPCO=0
37479 C       RETURN
37480 C       WRITE(6,*)' MGSQBS1 jump back from chain 6',
37481 C    &  CHAMAL,PHKT(5,6+IIGLU1)
37482         GO TO 3466
37483       ENDIF
37484       IF(IPIP.GE.3)THEN
37485 C     IF(NUMEV.EQ.-324)THEN
37486       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37487      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37488      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37489       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37490      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37491      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37492       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37493      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37494      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37495       ENDIF
37496       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
37497       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
37498       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
37499       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
37500       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
37501       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
37502       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
37503       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
37504       IF(IPIP.EQ.1)THEN
37505         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+3
37506         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
37507         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
37508         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
37509       ELSEIF(IPIP.EQ.2)THEN
37510         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
37511         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
37512         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
37513         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
37514 C       WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
37515       ENDIF
37516       ISTHKT(7+IIGLU1)  =931
37517       JMOHKT(1,7+IIGLU1)=NC2P
37518       JMOHKT(2,7+IIGLU1)=0
37519       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37520       JDAHKT(2,7+IIGLU1)=0
37521 C    create chain     9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37522       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
37523       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
37524       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
37525       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
37526 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
37527 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
37528       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
37529 C       IREJ=1
37530 C       WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
37531         IPCO=0
37532 C       RETURN
37533         GO TO 3466
37534       ENDIF
37535 C     PHKT(5,7)  =PHKK(5,NC2P)
37536       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
37537      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37538      *PHKT(1,7+IIGLU1)**2)
37539       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
37540       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
37541       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
37542       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
37543       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
37544       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
37545       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
37546       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
37547 C     Insert here the IIGLU2 gluons
37548       PG1=0.D0
37549       PG2=0.D0
37550       PG3=0.D0
37551       PG4=0.D0
37552       IF(IIGLU2.GE.1)THEN
37553       JJG=NC2P
37554       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37555         KKG=JJG+IIG-7-IIGLU1
37556         IDHKT(IIG)   =IDHKK(KKG)
37557         ISTHKT(IIG)  =921
37558         JMOHKT(1,IIG)=KKG
37559         JMOHKT(2,IIG)=0
37560         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37561         JDAHKT(2,IIG)=0
37562         PHKT(1,IIG)=PHKK(1,KKG)
37563         PG1=PG1+ PHKT(1,IIG)
37564         PHKT(2,IIG)=PHKK(2,KKG)
37565         PG2=PG2+ PHKT(2,IIG)
37566         PHKT(3,IIG)=PHKK(3,KKG)
37567         PG3=PG3+ PHKT(3,IIG)
37568         PHKT(4,IIG)=PHKK(4,KKG)
37569         PG4=PG4+ PHKT(4,IIG)
37570         PHKT(5,IIG)=PHKK(5,KKG)
37571         VHKT(1,IIG)  =VHKK(1,KKG)
37572         VHKT(2,IIG)  =VHKK(2,KKG)
37573         VHKT(3,IIG)  =VHKK(3,KKG)
37574         VHKT(4,IIG)  =VHKK(4,KKG)
37575         WHKT(1,IIG)  =WHKK(1,KKG)
37576         WHKT(2,IIG) =WHKK(2,KKG)
37577         WHKT(3,IIG) =WHKK(3,KKG)
37578         WHKT(4,IIG) =WHKK(4,KKG)
37579    81 CONTINUE
37580       ENDIF
37581       IDHKT(8+IIGLU1+IIGLU2)   =IP2
37582       ISTHKT(8+IIGLU1+IIGLU2)  =932
37583       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
37584       JMOHKT(2,8+IIGLU1+IIGLU2)=0
37585       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37586       JDAHKT(2,8+IIGLU1+IIGLU2)=0
37587       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
37588       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
37589       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
37590       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
37591 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
37592       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
37593      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37594      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37595       IF(XMIST.GT.0.D0)THEN
37596       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37597      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37598      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37599       ELSE
37600 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37601         PHKT(5,8+IIGLU1+IIGLU2)=0.D0
37602       ENDIF
37603       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
37604       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
37605       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
37606       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
37607       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
37608       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
37609       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
37610       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
37611       IDHKT(9+IIGLU1+IIGLU2)   =88888
37612       ISTHKT(9+IIGLU1+IIGLU2)  =94
37613       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37614       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37615       JDAHKT(1,9+IIGLU1+IIGLU2)=0
37616       JDAHKT(2,9+IIGLU1+IIGLU2)=0
37617       PHKT(1,9+IIGLU1+IIGLU2)
37618      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37619       PHKT(2,9+IIGLU1+IIGLU2)
37620      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37621       PHKT(3,9+IIGLU1+IIGLU2)
37622      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37623       PHKT(4,9+IIGLU1+IIGLU2)
37624      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37625       XMIST
37626      *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37627      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37628      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37629       IF(XMIST.GE.0.D0)THEN
37630       PHKT(5,9+IIGLU1+IIGLU2)
37631      *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37632      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37633      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37634       ELSE
37635 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37636        PHKT(5,1)=0.D0
37637       ENDIF
37638       IF(IPIP.GE.3)THEN
37639 C     IF(NUMEV.EQ.-324)THEN
37640       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37641      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37642      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37643       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37644       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37645      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
37646      * JDAHKT(1,IIG),
37647      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37648    91 CONTINUE
37649       WRITE(LOUT,*)8+IIGLU1+IIGLU2,
37650      * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
37651      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
37652      *JDAHKT(1,8+IIGLU1+IIGLU2),
37653      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37654       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37655      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37656      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37657      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37658       ENDIF
37659       CHAMAL=CHAB1
37660       IF(IPIP.EQ.1)THEN
37661         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37662       ELSEIF(IPIP.EQ.2)THEN
37663         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37664       ENDIF
37665       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37666 C       IREJ=1
37667         IPCO=0
37668 C       RETURN
37669 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
37670 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37671         GO TO 3466
37672       ENDIF
37673       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
37674       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
37675       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
37676       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
37677       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
37678       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
37679       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
37680       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
37681 C
37682       IPCO=0
37683       IGCOUN=9+IIGLU1+IIGLU2
37684        RETURN
37685        END
37686
37687 *$ CREATE MGSQBS1.FOR
37688 *COPY MGSQBS1
37689 C
37690 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37691       SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37692      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
37693 C
37694 C                  GSQBS-1 diagram (split projectile diquark)
37695 C
37696       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37697       SAVE
37698
37699       PARAMETER ( LINP = 10 ,
37700      &            LOUT = 6 ,
37701      &            LDAT = 9 )
37702
37703 * event history
37704
37705       PARAMETER (NMXHKK=200000)
37706
37707       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37708      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37709      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37710
37711 * extended event history
37712       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37713      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37714      &                IHIST(2,NMXHKK)
37715
37716 * Lorentz-parameters of the current interaction
37717       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37718      &                UMO,PPCM,EPROJ,PPROJ
37719
37720 * diquark-breaking mechanism
37721       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37722
37723 C
37724       PARAMETER (NTMHKK= 300)
37725       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37726      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37727      +(4,NTMHKK)
37728 *KEEP,XSEADI.
37729       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37730      +SSMIMQ,VVMTHR
37731 *KEEP,DPRIN.
37732       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37733 C
37734 C                  GSQBS-1 diagram (split projectile diquark)
37735 C
37736 C
37737 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37738 C     Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
37739 C
37740 C     Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
37741 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37742 C
37743 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37744 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37745 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37746 C
37747 C       Put new chains into COMMON /HKKTMP/
37748 C
37749       IIGLU1=NC1T-NC1P-1
37750       IIGLU2=NC2T-NC2P-1
37751       IGCOUN=0
37752 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37753       CVQ=1.D0
37754       NNNC1=IDHKK(NC1)/1000
37755       MMMC1=IDHKK(NC1)-NNNC1*1000
37756       KKKC1=ISTHKK(NC1)
37757       NNNC2=IDHKK(NC2)/1000
37758       MMMC2=IDHKK(NC2)-NNNC2*1000
37759       KKKC2=ISTHKK(NC2)
37760       IREJ=0
37761       IF(IPIP.EQ.3)THEN
37762       WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37763      *             ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
37764      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37765      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
37766       ENDIF
37767 C
37768 C
37769 C
37770 C     determine x-values of NC1P diquark
37771       XDIQP=PHKK(4,NC1P)*2.D0/UMO
37772       XVQT=PHKK(4,NC1T)*2.D0/UMO
37773 C
37774 C     determine x-values of sea quark pair
37775 C
37776       IPCO=1
37777       ICOU=0
37778  2234 CONTINUE
37779       ICOU=ICOU+1
37780       IF(ICOU.GE.500)THEN
37781         IREJ=1
37782         IF(ISQ.EQ.3)IREJ=3
37783         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
37784       IPCO=0
37785         RETURN
37786       ENDIF
37787       IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
37788      * UMO, XDIQP,XVQT
37789       XSQ=0.D0
37790       XSAQ=0.D0
37791 **NEW
37792 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37793       IF (IPIP.EQ.1) THEN
37794          XQMAX  = XDIQP/2.0D0
37795          XAQMAX = 2.D0*XVQT/3.0D0
37796       ELSE
37797          XQMAX  = 2.D0*XVQT/3.0D0
37798          XAQMAX = XDIQP/2.0D0
37799       ENDIF
37800       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37801       ISAQ = 6+ISQ
37802 C     write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37803 **
37804         IF(IPCO.GE.3)
37805      &     WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37806       IF(IREJ.GE.1)THEN
37807         IF(IPCO.GE.3)
37808      &     WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37809       IPCO=0
37810         RETURN
37811       ENDIF
37812       IF(IPIP.EQ.1)THEN
37813         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37814       ELSEIF(IPIP.EQ.2)THEN
37815         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37816       ENDIF
37817       IF(IPCO.GE.3)THEN
37818         WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37819      &  XDIQP,XVQT,XSQ,XSAQ
37820       ENDIF
37821 C
37822 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
37823 C
37824 C     XSQ=0.D0
37825       IF(IPIP.EQ.1)THEN
37826         XDIQP=XDIQP-XSQ
37827 **NEW
37828 C       IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
37829 **
37830         XVQT =XVQT -XSAQ
37831       ELSEIF(IPIP.EQ.2)THEN
37832         XDIQP=XDIQP-XSAQ
37833         XVQT =XVQT -XSQ
37834       ENDIF
37835       IF(IPCO.GE.3)
37836      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37837 C
37838 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37839 C
37840       XVTHRO=CVQ/UMO
37841       IVTHR=0
37842  3466 CONTINUE
37843       IF(IVTHR.EQ.10)THEN
37844         IREJ=1
37845         IF(ISQ.EQ.3)IREJ=3
37846         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
37847       IPCO=0
37848         RETURN
37849       ENDIF
37850       IVTHR=IVTHR+1
37851       XVTHR=XVTHRO/(201-IVTHR)
37852       UNOPRV=UNON
37853  380  CONTINUE
37854       IF(XVTHR.GT.0.66D0*XDIQP)THEN
37855         IREJ=1
37856         IF(ISQ.EQ.3)IREJ=3
37857         IF(IPCO.GE.3)
37858      &     WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR  large',
37859      *  XVTHR
37860       IPCO=0
37861         RETURN
37862       ENDIF
37863       IF(DT_RNDM(V).LT.0.5D0)THEN
37864         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37865         XVPQII=XDIQP-XVPQI
37866       ELSE
37867         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37868         XVPQI=XDIQP-XVPQII
37869       ENDIF
37870       IF(IPCO.GE.3)THEN
37871         WRITE(LOUT,'(A,4E12.4)')'  MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
37872      &  XVTHR,XDIQP,XVPQI,XVPQII
37873       ENDIF
37874 C
37875 C     Prepare 4 momenta of new chains and chain ends
37876 C
37877 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37878 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37879 C    +(4,NTMHKK)
37880 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37881 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37882 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37883       IF(IPIP.EQ.1)THEN
37884         XSQ1=XSQ
37885         XSAQ1=XSAQ
37886         ISQ1=ISQ
37887         ISAQ1=ISAQ
37888       ELSEIF(IPIP.EQ.2)THEN
37889         XSQ1=XSAQ
37890         XSAQ1=XSQ
37891         ISQ1=ISAQ
37892         ISAQ1=ISQ
37893       ENDIF
37894       KK11=IP11
37895 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
37896       KK21= IPP21
37897       KK22= IPP22
37898       XGIVE=0.D0
37899       IDHKT(4+IIGLU1)   =IP12
37900       ISTHKT(4+IIGLU1)  =921
37901       JMOHKT(1,4+IIGLU1)=NC1P
37902       JMOHKT(2,4+IIGLU1)=0
37903       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37904       JDAHKT(2,4+IIGLU1)=0
37905 **NEW
37906       IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
37907      &    (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
37908 **
37909       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37910       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37911       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37912       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37913 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37914       XXMIST=(PHKT(4,4+IIGLU1)**2-
37915      *              PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37916      *              PHKT(1,4+IIGLU1)**2)
37917       IF(XXMIST.GT.0.D0)THEN
37918         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37919       ELSE
37920         WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
37921         XXMIST=ABS(XXMIST)
37922         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37923       ENDIF
37924       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37925       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37926       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37927       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37928       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37929       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37930       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37931       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37932       IF(IPIP.EQ.1)THEN
37933         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
37934       ELSEIF(IPIP.EQ.2)THEN
37935         IDHKT(5+IIGLU1)   =ISAQ1
37936       ENDIF
37937       ISTHKT(5+IIGLU1)  =922
37938       JMOHKT(1,5+IIGLU1)=NC1T
37939       JMOHKT(2,5+IIGLU1)=0
37940       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37941       JDAHKT(2,5+IIGLU1)=0
37942 **NEW
37943       IF ((XSAQ1.LT.0.0D0).OR.(XVQT  .LT.0.0D0))
37944      &    WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
37945 **
37946       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37947       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37948       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37949       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37950 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
37951       XMIST=(PHKT(4,5+IIGLU1)**2-
37952      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37953      *PHKT(1,5+IIGLU1)**2)
37954       IF(XMIST.GT.0.D0)THEN
37955       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
37956      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37957      *PHKT(1,5+IIGLU1)**2)
37958       ELSE
37959 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37960         PHKT(5,5+IIGLU1)=0.D0
37961       ENDIF
37962       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37963       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37964       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37965       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37966       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37967       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37968       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37969       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37970       IDHKT(6+IIGLU1)   =88888
37971 C     IDHKT(6)   =1000*NNNC1+MMMC1
37972       ISTHKT(6+IIGLU1)  =93
37973 C     ISTHKT(6)  =KKKC1
37974       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37975       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37976       JDAHKT(1,6+IIGLU1)=0
37977       JDAHKT(2,6+IIGLU1)=0
37978       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37979       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37980       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37981       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37982       PHKT(5,6+IIGLU1)
37983      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37984      *            -PHKT(3,6+IIGLU1)**2)
37985       CHAMAL=CHAM1
37986       IF(IPIP.EQ.1)THEN
37987         IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
37988       ELSEIF(IPIP.EQ.2)THEN
37989         IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
37990       ENDIF
37991       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37992         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37993 C                    we drop chain 6 and give the energy to chain 3
37994           IDHKT(6+IIGLU1)=33888
37995           XGIVE=1.D0
37996 C         WRITE(6,*)' drop chain 6 xgive=1'
37997           GO TO 7788
37998         ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
37999 C                    we drop chain 6 and give the energy to chain 3
38000 C                    and change KK11 to IDHKT(4)
38001           IDHKT(6+IIGLU1)=33888
38002           XGIVE=1.D0
38003 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
38004           KK11=IDHKT(4+IIGLU1)
38005           GO TO 7788
38006         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
38007 C                    we drop chain 6 and give the energy to chain 3
38008 C                    and change KK21 to IDHKT(4)
38009 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
38010           IDHKT(6+IIGLU1)=33888
38011           XGIVE=1.D0
38012 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
38013           KK21=IDHKT(4+IIGLU1)
38014           GO TO 7788
38015         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
38016 C                    we drop chain 6 and give the energy to chain 3
38017 C                    and change KK22 to IDHKT(4)
38018 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
38019           IDHKT(6+IIGLU1)=33888
38020           XGIVE=1.D0
38021 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
38022           KK22=IDHKT(4+IIGLU1)
38023           GO TO 7788
38024         ENDIF
38025 C       IREJ=1
38026         IPCO=0
38027 C       RETURN
38028 C       WRITE(6,*)' MGSQBS1 jump back from chain 6'
38029         GO TO 3466
38030       ENDIF
38031  7788 CONTINUE
38032       IF(IPIP.GE.3)THEN
38033       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38034      * JMOHKT(1,4+IIGLU1),
38035      * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38036      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38037       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38038      * JMOHKT(1,5+IIGLU1),
38039      * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38040      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38041       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38042      * JMOHKT(1,6+IIGLU1),
38043      * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38044      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38045       ENDIF
38046       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
38047       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
38048       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
38049       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
38050       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
38051       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
38052       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
38053       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
38054 C     IDHKT(1)   =IP11
38055       IDHKT(1)   =KK11
38056       ISTHKT(1)  =921
38057       JMOHKT(1,1)=NC1P
38058       JMOHKT(2,1)=0
38059       JDAHKT(1,1)=3+IIGLU1
38060       JDAHKT(2,1)=0
38061       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38062 C    * +0.5D0*PHKK(1,NC2P)
38063      *+XGIVE*PHKT(1,4+IIGLU1)
38064       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38065 C    * +0.5D0*PHKK(2,NC2P)
38066      *+XGIVE*PHKT(2,4+IIGLU1)
38067       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38068 C    * +0.5D0*PHKK(3,NC2P)
38069      *+XGIVE*PHKT(3,4+IIGLU1)
38070       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38071 C    * +0.5D0*PHKK(4,NC2P)
38072      *+XGIVE*PHKT(4,4+IIGLU1)
38073 C     PHKT(5,1)  =PHKK(5,NC1P)
38074       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38075      *PHKT(1,1)**2)
38076       IF(XMIST.GE.0.D0)THEN
38077       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38078      *PHKT(1,1)**2)
38079       ELSE
38080 C      WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
38081        PHKT(5,1)=0.D0
38082       ENDIF
38083       VHKT(1,1)  =VHKK(1,NC1P)
38084       VHKT(2,1)  =VHKK(2,NC1P)
38085       VHKT(3,1)  =VHKK(3,NC1P)
38086       VHKT(4,1)  =VHKK(4,NC1P)
38087       WHKT(1,1)  =WHKK(1,NC1P)
38088       WHKT(2,1)  =WHKK(2,NC1P)
38089       WHKT(3,1)  =WHKK(3,NC1P)
38090       WHKT(4,1)  =WHKK(4,NC1P)
38091 C     Add here IIGLU1 gluons to this chaina
38092       PG1=0.D0
38093       PG2=0.D0
38094       PG3=0.D0
38095       PG4=0.D0
38096       IF(IIGLU1.GE.1)THEN
38097       JJG=NC1P
38098       DO 61 IIG=2,2+IIGLU1-1
38099         KKG=JJG+IIG-1
38100         IDHKT(IIG)   =IDHKK(KKG)
38101         ISTHKT(IIG)  =921
38102         JMOHKT(1,IIG)=KKG
38103         JMOHKT(2,IIG)=0
38104         JDAHKT(1,IIG)=3+IIGLU1
38105         JDAHKT(2,IIG)=0
38106         PHKT(1,IIG)=PHKK(1,KKG)
38107         PG1=PG1+ PHKT(1,IIG)
38108         PHKT(2,IIG)=PHKK(2,KKG)
38109         PG2=PG2+ PHKT(2,IIG)
38110         PHKT(3,IIG)=PHKK(3,KKG)
38111         PG3=PG3+ PHKT(3,IIG)
38112         PHKT(4,IIG)=PHKK(4,KKG)
38113         PG4=PG4+ PHKT(4,IIG)
38114         PHKT(5,IIG)=PHKK(5,KKG)
38115         VHKT(1,IIG)  =VHKK(1,KKG)
38116         VHKT(2,IIG)  =VHKK(2,KKG)
38117         VHKT(3,IIG)  =VHKK(3,KKG)
38118         VHKT(4,IIG)  =VHKK(4,KKG)
38119         WHKT(1,IIG)  =WHKK(1,KKG)
38120         WHKT(2,IIG)  =WHKK(2,KKG)
38121         WHKT(3,IIG)  =WHKK(3,KKG)
38122         WHKT(4,IIG)  =WHKK(4,KKG)
38123    61 CONTINUE
38124       ENDIF
38125 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
38126       IF(IPIP.EQ.1)THEN
38127         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22+3
38128         IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
38129         IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
38130         IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
38131       ELSEIF(IPIP.EQ.2)THEN
38132         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22-3
38133         IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
38134         IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
38135         IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
38136       ENDIF
38137       ISTHKT(2+IIGLU1)  =922
38138       JMOHKT(1,2+IIGLU1)=NC2T
38139       JMOHKT(2,2+IIGLU1)=0
38140       JDAHKT(1,2+IIGLU1)=3+IIGLU1
38141       JDAHKT(2,2+IIGLU1)=0
38142       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
38143      *+XGIVE*PHKT(1,5+IIGLU1)
38144       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
38145      *+XGIVE*PHKT(2,5+IIGLU1)
38146       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
38147      *+XGIVE*PHKT(3,5+IIGLU1)
38148       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
38149      *+XGIVE*PHKT(4,5+IIGLU1)
38150 C     PHKT(5,2)  =PHKK(5,NC2T)
38151       XMIST=(PHKT(4,2+IIGLU1)**2-
38152      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38153      *PHKT(1,2+IIGLU1)**2)
38154       IF(XMIST.GT.0.D0)THEN
38155       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
38156      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38157      *PHKT(1,2+IIGLU1)**2)
38158       ELSE
38159 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38160       PHKT(5,2+IIGLU1)=0.D0
38161       ENDIF
38162       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
38163       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
38164       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
38165       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
38166       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
38167       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
38168       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
38169       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
38170       IDHKT(3+IIGLU1)   =88888
38171 C     IDHKT(3)   =1000*NNNC1+MMMC1+10
38172       ISTHKT(3+IIGLU1)  =93
38173 C     ISTHKT(3)  =KKKC1
38174       JMOHKT(1,3+IIGLU1)=1
38175       JMOHKT(2,3+IIGLU1)=2+IIGLU1
38176       JDAHKT(1,3+IIGLU1)=0
38177       JDAHKT(2,3+IIGLU1)=0
38178       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38179       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38180       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38181       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38182       PHKT(5,3+IIGLU1)
38183      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38184      *            -PHKT(3,3+IIGLU1)**2)
38185       IF(IPIP.GE.3)THEN
38186       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38187      * JDAHKT(1,1),
38188      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38189       DO 71 IIG=2,2+IIGLU1-1
38190       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38191      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38192      * JDAHKT(1,IIG),
38193      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38194    71 CONTINUE
38195       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
38196      &             IDHKT(2),JMOHKT(1,2+IIGLU1),
38197      * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38198      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38199       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38200      * JMOHKT(1,3+IIGLU1),
38201      * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38202      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38203       ENDIF
38204       CHAMAL=CHAB1
38205 **NEW
38206 C     IF(IPIP.EQ.1)THEN
38207 C       IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
38208 C     ELSEIF(IPIP.EQ.2)THEN
38209 C       IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
38210 C     ENDIF
38211       IF(IPIP.EQ.1)THEN
38212         IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
38213       ELSEIF(IPIP.EQ.2)THEN
38214         IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
38215       ENDIF
38216 **
38217       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38218 C       IREJ=1
38219         IPCO=0
38220 C       RETURN
38221 C       WRITE(6,*)' MGSQBS1 jump back from chain 3'
38222         GO TO 3466
38223       ENDIF
38224       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
38225       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
38226       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
38227       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
38228       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
38229       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
38230       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
38231       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
38232       IF(IPIP.EQ.1)THEN
38233         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ1+3
38234         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38235         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38236         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38237       ELSEIF(IPIP.EQ.2)THEN
38238         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
38239         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38240         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38241         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38242 C       WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
38243       ENDIF
38244       ISTHKT(7+IIGLU1)  =921
38245       JMOHKT(1,7+IIGLU1)=NC2P
38246       JMOHKT(2,7+IIGLU1)=0
38247       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38248       JDAHKT(2,7+IIGLU1)=0
38249 C     PHKT(1,7)  =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
38250 C     PHKT(2,7)  =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
38251 C     PHKT(3,7)  =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
38252 C     PHKT(4,7+IIGLU1)  =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
38253 **NEW
38254       IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
38255      &    WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
38256 **
38257       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38258       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38259       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38260       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38261 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38262 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38263       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38264 C       IREJ=1
38265 C       WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
38266         IPCO=0
38267 C       RETURN
38268         GO TO 3466
38269       ENDIF
38270 C     PHKT(5,7)  =PHKK(5,NC2P)
38271       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
38272      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38273      *PHKT(1,7+IIGLU1)**2)
38274       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
38275       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
38276       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
38277       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
38278       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
38279       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
38280       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
38281       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
38282 C     Insert here the IIGLU2 gluons
38283       PG1=0.D0
38284       PG2=0.D0
38285       PG3=0.D0
38286       PG4=0.D0
38287       IF(IIGLU2.GE.1)THEN
38288       JJG=NC2P
38289       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38290         KKG=JJG+IIG-7-IIGLU1
38291         IDHKT(IIG)   =IDHKK(KKG)
38292         ISTHKT(IIG)  =921
38293         JMOHKT(1,IIG)=KKG
38294         JMOHKT(2,IIG)=0
38295         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38296         JDAHKT(2,IIG)=0
38297         PHKT(1,IIG)=PHKK(1,KKG)
38298         PG1=PG1+ PHKT(1,IIG)
38299         PHKT(2,IIG)=PHKK(2,KKG)
38300         PG2=PG2+ PHKT(2,IIG)
38301         PHKT(3,IIG)=PHKK(3,KKG)
38302         PG3=PG3+ PHKT(3,IIG)
38303         PHKT(4,IIG)=PHKK(4,KKG)
38304         PG4=PG4+ PHKT(4,IIG)
38305         PHKT(5,IIG)=PHKK(5,KKG)
38306         VHKT(1,IIG)  =VHKK(1,KKG)
38307         VHKT(2,IIG)  =VHKK(2,KKG)
38308         VHKT(3,IIG)  =VHKK(3,KKG)
38309         VHKT(4,IIG)  =VHKK(4,KKG)
38310         WHKT(1,IIG)  =WHKK(1,KKG)
38311         WHKT(2,IIG)  =WHKK(2,KKG)
38312         WHKT(3,IIG)  =WHKK(3,KKG)
38313         WHKT(4,IIG)  =WHKK(4,KKG)
38314    81 CONTINUE
38315       ENDIF
38316       IDHKT(8+IIGLU1+IIGLU2)   =IP2
38317       ISTHKT(8+IIGLU1+IIGLU2)  =922
38318       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38319       JMOHKT(2,8+IIGLU1+IIGLU2)=0
38320       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38321       JDAHKT(2,8+IIGLU1+IIGLU2)=0
38322 **NEW
38323       IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
38324      &    WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
38325 **
38326       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38327       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38328       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38329       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38330 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
38331       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38332      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38333      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38334       IF(XMIST.GT.0.D0)THEN
38335       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38336      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38337      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38338       ELSE
38339 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38340       PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38341       ENDIF
38342       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
38343       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
38344       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
38345       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
38346       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
38347       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
38348       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
38349       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
38350       IDHKT(9+IIGLU1+IIGLU2)   =88888
38351 C     IDHKT(9)   =1000*NNNC2+MMMC2+10
38352       ISTHKT(9+IIGLU1+IIGLU2)  =93
38353 C     ISTHKT(9)  =KKKC2
38354       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38355       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38356       JDAHKT(1,9+IIGLU1+IIGLU2)=0
38357       JDAHKT(2,9+IIGLU1+IIGLU2)=0
38358       PHKT(1,9+IIGLU1+IIGLU2)  =PHKT(1,7+IIGLU1)
38359      * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
38360       PHKT(2,9+IIGLU1+IIGLU2)  =PHKT(2,7+IIGLU1)
38361      * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
38362       PHKT(3,9+IIGLU1+IIGLU2)  =PHKT(3,7+IIGLU1)
38363      * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
38364       PHKT(4,9+IIGLU1+IIGLU2)  =PHKT(4,7+IIGLU1)
38365      * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
38366       PHKT(5,9+IIGLU1+IIGLU2)
38367      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38368      * PHKT(2,9+IIGLU1+IIGLU2)**2
38369      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38370       IF(IPIP.GE.3)THEN
38371       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38372      * JMOHKT(1,7+IIGLU1),
38373      * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38374      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38375       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38376       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38377      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38378      * JDAHKT(1,IIG),
38379      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38380    91 CONTINUE
38381       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38382      * IDHKT(8+IIGLU1+IIGLU2),
38383      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38384      * JDAHKT(1,8+IIGLU1+IIGLU2),
38385      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38386       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38387      * IDHKT(9+IIGLU1+IIGLU2),
38388      * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
38389      * JDAHKT(1,9+IIGLU1+IIGLU2),
38390      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38391       ENDIF
38392       CHAMAL=CHAB1
38393       IF(IPIP.EQ.1)THEN
38394         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38395       ELSEIF(IPIP.EQ.2)THEN
38396         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38397       ENDIF
38398       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38399 C       IREJ=1
38400         IPCO=0
38401 C       RETURN
38402 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
38403 C    &  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38404         GO TO 3466
38405       ENDIF
38406       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
38407       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
38408       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
38409       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
38410       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
38411       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
38412       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
38413       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
38414 C
38415       IGCOUN=9+IIGLU1+IIGLU2
38416       IPCO=0
38417        RETURN
38418        END
38419
38420 *$ CREATE HKKHKT.FOR
38421 *COPY HKKHKT
38422 C
38423 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38424 C
38425       SUBROUTINE HKKHKT(I,J)
38426       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38427       SAVE
38428
38429 * event history
38430
38431       PARAMETER (NMXHKK=200000)
38432
38433       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38434      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38435      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38436
38437 * extended event history
38438       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38439      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38440      &                IHIST(2,NMXHKK)
38441
38442       PARAMETER (NTMHKK= 300)
38443       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38444      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38445      +(4,NTMHKK)
38446 C
38447       ISTHKK(I)  =ISTHKT(J)
38448       IDHKK(I)   =IDHKT(J)
38449 C     IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
38450       IF(IDHKK(I).EQ.88888)THEN
38451 C       JMOHKK(1,I)=I-2
38452 C       JMOHKK(2,I)=I-1
38453         JMOHKK(1,I)=I-(J-JMOHKT(1,J))
38454         JMOHKK(2,I)=I-(J-JMOHKT(2,J))
38455       ELSE
38456         JMOHKK(1,I)=JMOHKT(1,J)
38457         JMOHKK(2,I)=JMOHKT(2,J)
38458       ENDIF
38459       JDAHKK(1,I)=JDAHKT(1,J)
38460       JDAHKK(2,I)=JDAHKT(2,J)
38461 C       IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
38462 C       JDAHKK(1,I)=I+2
38463 C     ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
38464 C       JDAHKK(1,I)=I+1
38465 C     ENDIF
38466       IF(JDAHKT(1,J).GT.0)THEN
38467         JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
38468       ENDIF
38469       PHKK(1,I)  =PHKT(1,J)
38470       PHKK(2,I)  =PHKT(2,J)
38471       PHKK(3,I)  =PHKT(3,J)
38472       PHKK(4,I)  =PHKT(4,J)
38473       PHKK(5,I)  =PHKT(5,J)
38474       VHKK(1,I)  =VHKT(1,J)
38475       VHKK(2,I)  =VHKT(2,J)
38476       VHKK(3,I)  =VHKT(3,J)
38477       VHKK(4,I)  =VHKT(4,J)
38478       WHKK(1,I)  =WHKT(1,J)
38479       WHKK(2,I)  =WHKT(2,J)
38480       WHKK(3,I)  =WHKT(3,J)
38481       WHKK(4,I)  =WHKT(4,J)
38482       RETURN
38483       END
38484
38485 *$ CREATE DT_DBREAK.FOR
38486 *COPY DT_DBREAK
38487 *
38488 *===dbreak=============================================================*
38489 *
38490       SUBROUTINE DT_DBREAK(MODE)
38491
38492 ************************************************************************
38493 * This is the steering subroutine for the different diquark breaking   *
38494 * mechanisms.                                                          *
38495 *                                                                      *
38496 * MODE = 1  breaking of projectile diquark in qq-q chain using         *
38497 *           a sea quark (q-qq chain) of the same projectile            *
38498 *      = 2  breaking of target     diquark in q-qq chain using         *
38499 *           a sea quark (qq-q chain) of the same target                *
38500 *      = 3  breaking of projectile diquark in qq-q chain using         *
38501 *           a sea quark (q-aq chain) of the same projectile            *
38502 *      = 4  breaking of target     diquark in q-qq chain using         *
38503 *           a sea quark (aq-q chain) of the same target                *
38504 *      = 5  breaking of projectile anti-diquark in aqaq-aq chain using *
38505 *           a sea anti-quark (aq-aqaq chain) of the same projectile    *
38506 *      = 6  breaking of target     anti-diquark in aq-aqaq chain using *
38507 *           a sea anti-quark (aqaq-aq chain) of the same target        *
38508 *      = 7  breaking of projectile anti-diquark in aqaq-aq chain using *
38509 *           a sea anti-quark (aq-q chain) of the same projectile       *
38510 *      = 8  breaking of target     anti-diquark in aq-aqaq chain using *
38511 *           a sea anti-quark (q-aq chain) of the same target           *
38512 *                                                                      *
38513 * Original version by J. Ranft.                                        *
38514 * This version dated 17.5.00  is written by S. Roesler.                *
38515 ************************************************************************
38516
38517       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38518       SAVE
38519
38520       PARAMETER ( LINP = 10 ,
38521      &            LOUT = 6 ,
38522      &            LDAT = 9 )
38523
38524 * event history
38525
38526       PARAMETER (NMXHKK=200000)
38527
38528       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38529      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38530      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38531
38532 * extended event history
38533       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38534      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38535      &                IHIST(2,NMXHKK)
38536
38537 * flags for input different options
38538       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
38539       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
38540      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
38541
38542 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
38543       PARAMETER (MAXCHN=10000)
38544       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
38545
38546 * diquark-breaking mechanism
38547       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38548
38549 * flags for particle decays
38550       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
38551      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
38552      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
38553
38554 *
38555 * chain identifiers
38556 * ( 1 = q-aq,   2 = aq-q,   3 = q-qq,   4 = qq-q,
38557 *   5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
38558       DIMENSION IDCHN1(8),IDCHN2(8)
38559       DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
38560       DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
38561 *
38562 * parton identifiers
38563 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
38564 *   +-51/52 = unitarity-sea, +-61/62 = gluons )
38565       DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
38566       DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
38567      &             31, 31, 31, 31, 31, 31, 31, 31,
38568      &             41, 41, 41, 41, 51, 51, 51, 51/
38569       DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
38570      &             32, 32, 32, 32, 32, 32, 32, 32,
38571      &             42, 42, 42, 42, 52, 52, 52, 52/
38572       DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
38573      &             51, 31, 41, 41, 31, 31, 31, 31,
38574      &              0, 41, 51, 51, 51, 51, 51, 51/
38575       DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
38576      &             32, 52, 42, 42, 32, 32, 32, 32,
38577      &             42,  0, 52, 52, 52, 52, 52, 52/
38578
38579       IF (NCHAIN.LE.0) RETURN
38580       DO 1 I=1,NCHAIN
38581          IDX1 = IDXCHN(1,I)
38582          IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
38583          IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
38584          IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
38585      &       .AND.
38586      &        ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
38587      &                                    (IS1P.EQ.ISP1P(MODE,3)))
38588      &       .AND.
38589      &        ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
38590      &                                    (IS1T.EQ.ISP1T(MODE,3)))
38591      &      ) THEN
38592             DO 2 J=1,NCHAIN
38593                IDX2 = IDXCHN(1,J)
38594                IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
38595                IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
38596                IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
38597      &             .AND.
38598      &              ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
38599      &                                      .OR.(IS2P.EQ.ISP2P(MODE,3)))
38600      &             .AND.
38601      &              ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
38602      &                                      .OR.(IS2T.EQ.ISP2T(MODE,3)))
38603      &            ) THEN
38604 *   find mother nucleons of the diquark to be splitted and of the
38605 *   sea-quark and reject this combination if it is not the same
38606                   IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
38607      &                (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
38608                      IANCES = 1
38609                   ELSE
38610                      IANCES = 2
38611                   ENDIF
38612                   IDXMO1 = JMOHKK(IANCES,IDX1)
38613     4             CONTINUE
38614                   IF ((JMOHKK(1,IDXMO1).NE.0).AND.
38615      &                (JMOHKK(2,IDXMO1).NE.0)) THEN
38616                      IANC = IANCES
38617                   ELSE
38618                      IANC = 1
38619                   ENDIF
38620                   IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
38621                      IDXMO1 = JMOHKK(IANC,IDXMO1)
38622                      GOTO 4
38623                   ENDIF
38624                   IDXMO2 = JMOHKK(IANCES,IDX2)
38625     5             CONTINUE
38626                   IF ((JMOHKK(1,IDXMO2).NE.0).AND.
38627      &                (JMOHKK(2,IDXMO2).NE.0)) THEN
38628                      IANC = IANCES
38629                   ELSE
38630                      IANC = 1
38631                   ENDIF
38632                   IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
38633                      IDXMO2 = JMOHKK(IANC,IDXMO2)
38634                      GOTO 5
38635                   ENDIF
38636                   IF (IDXMO1.NE.IDXMO2) GOTO 2
38637 *   quark content of projectile parton
38638                   IP1   = IDHKK(JMOHKK(1,IDX1))
38639                   IP11  = IP1/1000
38640                   IP12  = (IP1-1000*IP11)/100
38641                   IP2   = IDHKK(JMOHKK(2,IDX1))
38642                   IP21  = IP2/1000
38643                   IP22  = (IP2-1000*IP21)/100
38644 *   quark content of target parton
38645                   IT1  = IDHKK(JMOHKK(1,IDX2))
38646                   IT11 = IT1/1000
38647                   IT12 = (IT1-1000*IT11)/100
38648                   IT2  = IDHKK(JMOHKK(2,IDX2))
38649                   IT21 = IT2/1000
38650                   IT22 = (IT2-1000*IT21)/100
38651 *   split diquark and form new chains
38652                   IF (MODE.EQ.1) THEN
38653                      IF (IT1.EQ.4) GOTO 2
38654                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38655      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38656      &                         IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
38657                   ELSEIF (MODE.EQ.2) THEN
38658                      IF (IT2.EQ.4) GOTO 2
38659                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38660      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38661      &                         IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
38662                   ELSEIF (MODE.EQ.3) THEN
38663                      IF (IT1.EQ.4) GOTO 2
38664                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38665      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38666      &                         IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
38667                   ELSEIF (MODE.EQ.4) THEN
38668                      IF (IT2.EQ.4) GOTO 2
38669                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38670      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38671      &                         IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
38672                   ELSEIF (MODE.EQ.5) THEN
38673                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38674      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38675      &                         IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
38676                   ELSEIF (MODE.EQ.6) THEN
38677                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38678      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38679      &                         IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
38680                   ELSEIF (MODE.EQ.7) THEN
38681                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38682      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38683      &                         IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
38684                   ELSEIF (MODE.EQ.8) THEN
38685                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38686      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38687      &                         IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
38688                   ENDIF
38689                   IF (IREJ.GE.1) THEN
38690                      if ((ipq.lt.0).or.(ipq.ge.4))
38691      &                  write(LOUT,*) 'ipq !!!',ipq,mode
38692                      DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38693 *   accept or reject new chains corresponding to PDBSEA
38694                   ELSE
38695                      IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
38696                         ACC   = DBRKA(1,MODE)+DBRKA(2,MODE)
38697                         REJ   = DBRKR(1,MODE)+DBRKR(2,MODE)
38698                      ELSEIF (IPQ.EQ.3) THEN
38699                         ACC   = DBRKA(3,MODE)
38700                         REJ   = DBRKR(3,MODE)
38701                      ELSE
38702                         WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
38703                         STOP
38704                      ENDIF
38705                      IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
38706                         DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
38707                         IACC = 1
38708                      ELSE
38709                         DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38710                         IACC = 0
38711                      ENDIF
38712 *   new chains have been accepted and are now copied into HKKEVT
38713                      IF (IACC.EQ.1) THEN
38714                         IF (LEMCCK) THEN
38715                            CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
38716      &                                    PHKK(3,IDX1),PHKK(4,IDX1),
38717      &                                    1,IDUM1,IDUM2)
38718                            CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
38719      &                                    PHKK(3,IDX2),PHKK(4,IDX2),
38720      &                                    2,IDUM1,IDUM2)
38721                         ENDIF
38722                         IDHKK(IDX1) = 99888
38723                         IDHKK(IDX2) = 99888
38724                         IDXCHN(2,I) = -1
38725                         IDXCHN(2,J) = -1
38726                         DO 3 K=1,IGCOUN
38727                            NHKK = NHKK+1
38728                            CALL HKKHKT(NHKK,K)
38729                            IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
38730                               PX = -PHKK(1,NHKK)
38731                               PY = -PHKK(2,NHKK)
38732                               PZ = -PHKK(3,NHKK)
38733                               PE = -PHKK(4,NHKK)
38734                               CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
38735                            ENDIF
38736     3                   CONTINUE
38737                         IF (LEMCCK) THEN
38738                            CHKLEV = 0.1D0
38739                            CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
38740      &                                                             IREJ)
38741                            IF (IREJ.NE.0) CALL DT_EVTOUT(4)
38742                         ENDIF
38743                         GOTO 1
38744                      ENDIF
38745                   ENDIF
38746                ENDIF
38747     2       CONTINUE
38748          ENDIF
38749     1 CONTINUE
38750       RETURN
38751       END
38752
38753 *$ CREATE DT_CQPAIR.FOR
38754 *COPY DT_CQPAIR
38755 *
38756 *===cqpair=============================================================*
38757 *
38758       SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
38759
38760 ************************************************************************
38761 * This subroutine Creates a Quark-antiquark PAIR from the sea.         *
38762 *                                                                      *
38763 *   XQMAX   maxium energy fraction of quark (input)                    *
38764 *   XAQMAX  maxium energy fraction of antiquark (input)                *
38765 *   XQ      energy fraction of quark (output)                          *
38766 *   XAQ     energy fraction of antiquark (output)                      *
38767 *   IFLV    quark flavour (- antiquark flavor) (output)                *
38768 *                                                                      *
38769 * This version dated 14.5.00  is written by S. Roesler.                *
38770 ************************************************************************
38771
38772       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38773       SAVE
38774
38775       PARAMETER ( LINP = 10 ,
38776      &            LOUT = 6 ,
38777      &            LDAT = 9 )
38778
38779 * Lorentz-parameters of the current interaction
38780       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38781      &                UMO,PPCM,EPROJ,PPROJ
38782
38783 *
38784       IREJ = 0
38785       XQ   = 0.0D0
38786       XAQ  = 0.0D0
38787 *
38788 * sample quark flavour
38789 *
38790 *  set seasq here (the one from DTCHAI should be used in the future)
38791       SEASQ = 0.5D0
38792       IFLV  = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
38793 *
38794 * sample energy fractions of sea pair
38795 * we first sample the energy fraction of a gluon and then split the gluon
38796 *
38797 *  maximum energy fraction of the gluon forced via input
38798       XGMAXI = XQMAX+XAQMAX
38799 *  minimum energy fraction of the gluon
38800       XTHR1 = 4.0D0 /UMO**2
38801       XTHR2 = 0.54D0/UMO**1.5D0
38802       XGMIN = MAX(XTHR1,XTHR2)
38803 *  maximum energy fraction of the gluon
38804       XGMAX = 0.3D0
38805       XGMAX = MIN(XGMAXI,XGMAX)
38806       IF (XGMIN.GE.XGMAX) THEN
38807          IREJ = 1
38808          RETURN
38809       ENDIF
38810 *
38811 *  sample energy fraction of the gluon
38812       NLOOP = 0
38813     1 CONTINUE
38814       NLOOP = NLOOP+1
38815       IF (NLOOP.GE.50) THEN
38816          IREJ = 1
38817          RETURN
38818       ENDIF
38819       XGLUON = DT_SAMSQX(XGMIN,XGMAX)
38820       EGLUON = XGLUON*UMO/2.0D0
38821 *
38822 *  split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
38823       ZMIN = MIN(0.1D0,0.5D0/EGLUON)
38824       ZMAX = 1.0D0-ZMIN
38825       RZ   = DT_RNDM(ZMAX)
38826       XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
38827       RQ   = DT_RNDM(ZMAX)
38828       IF (RQ.LT.0.5D0) THEN
38829          XQ  = XGLUON*XHLP
38830          XAQ = XGLUON-XQ
38831       ELSE
38832          XAQ = XGLUON*XHLP
38833          XQ  = XGLUON-XAQ
38834       ENDIF
38835       IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
38836
38837       RETURN
38838       END