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
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       NCP    = 0
5556       NCT    = 0
5557
5558     1 CONTINUE
5559       ICSAMP = ICSAMP+1
5560       NC     = NC+1
5561       IF (MOD(NC,10).EQ.0) THEN
5562          WRITE(LOUT,1000) NEVHKK
5563  1000    FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5564          GOTO 9999
5565       ENDIF
5566
5567 * initialize DTEVT1/DTEVT2
5568       CALL DT_EVTINI
5569
5570 * We need the following only in order to sample nucleon coordinates.
5571 * However we don't have parameters (cross sections, slope etc.)
5572 * for neutrinos available. Therefore switch projectile to proton
5573 * in this case.
5574       IF (MCGENE.EQ.4) THEN
5575          JJPROJ = 1
5576       ELSE
5577          JJPROJ = IJPROJ
5578       ENDIF
5579
5580    10 CONTINUE
5581       IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5582 * make sure that Glauber-formalism is called each time the interaction
5583 * configuration changed
5584      &     (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5585      &     (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5586 * sample number of nucleon-nucleon coll. according to Glauber-form.
5587          CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5588          NWTSAM = NN
5589          NWASAM = NP
5590          NWBSAM = NT
5591          NEVOLD = NEVHKK
5592          IPOLD  = IP
5593          ITOLD  = IT
5594          JJPOLD = JJPROJ
5595          EPROLD = EPROJ
5596       DO 8 I=1, IP
5597         NCP = NCP+JSSH(I)
5598 *        WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP
5599     8 CONTINUE
5600       DO 9 I=1, IT
5601         NCT = NCT+JTSH(I)
5602 *        WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT
5603     9 CONTINUE
5604       ENDIF
5605
5606 * force diffractive particle production in h-K interactions
5607       IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5608      &    (IP.EQ.1).AND.(NN.NE.1)) THEN
5609          NEVOLD = 0
5610          GOTO 10
5611       ENDIF
5612
5613 * check number of involved proj. nucl. (NP) if central prod.is requested
5614       IF (ICENTR.GT.0) THEN
5615          CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5616          IF (IBACK.GT.0) GOTO 10
5617       ENDIF
5618
5619 * get initial nucleon-configuration in projectile and target
5620 * rest-system (including Fermi-momenta if requested)
5621       CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5622       MODE = 2
5623       IF (EPROJ.LE.EHADTH) MODE = 3
5624       CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5625
5626       IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5627
5628 * activate HADRIN at low energies (implemented for h-N scattering only)
5629          IF (EPROJ.LE.EHADHI) THEN
5630             IF (EHADTH.LT.ZERO) THEN
5631 *   smooth transition btwn. DPM and HADRIN
5632                FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5633                RR   = DT_RNDM(FRAC)
5634                IF (RR.GT.FRAC) THEN
5635                   IF (IP.EQ.1) THEN
5636                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5637                      IF (IREJ1.GT.0) GOTO 1
5638                      RETURN
5639                   ELSE
5640                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5641                   ENDIF
5642                ENDIF
5643             ELSE
5644 *   fixed threshold for onset of production via HADRIN
5645                IF (EPROJ.LE.EHADTH) THEN
5646                   IF (IP.EQ.1) THEN
5647                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5648                      IF (IREJ1.GT.0) GOTO 1
5649                      RETURN
5650                   ELSE
5651                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5652                   ENDIF
5653                ENDIF
5654             ENDIF
5655          ENDIF
5656  1001    FORMAT(1X,'KKEVNT:   warning! interaction of proj. (m=',
5657      &          I3,') with target (m=',I3,')',/,11X,
5658      &          'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5659      &          'GeV) cannot be handled')
5660
5661 * sampling of momentum-x fractions & flavors of chain ends
5662          CALL DT_SPLPTN(NN)
5663
5664 * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5665          CALL DT_NUC2CM
5666
5667 * collect momenta of chain ends and put them into DTEVT1
5668          CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5669          IF (IREJ1.NE.0) GOTO 1
5670
5671       ENDIF
5672
5673 * handle chains including fragmentation (two-chain approximation)
5674       IF (MCGENE.EQ.1) THEN
5675 *  two-chain approximation
5676          CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5677          IF (IREJ1.NE.0) THEN
5678             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5679             GOTO 1
5680          ENDIF
5681       ELSEIF (MCGENE.EQ.2) THEN
5682 *  multiple-Po exchange including minijets
5683          CALL DT_EVENTB(NCSY,IREJ1)
5684          IF (IREJ1.NE.0) THEN
5685             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5686             GOTO 1
5687          ENDIF
5688       ELSEIF (MCGENE.EQ.3) THEN
5689          STOP ' This version does not contain LEPTO !'
5690
5691       ELSEIF (MCGENE.EQ.4) THEN
5692 *  quasi-elastic neutrino scattering
5693          CALL DT_EVENTD(IREJ1)
5694          IF (IREJ1.NE.0) THEN
5695             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5696             GOTO 1
5697          ENDIF
5698       ELSE
5699          WRITE(LOUT,1002) MCGENE
5700  1002    FORMAT(1X,'KKEVNT:   warning! event-generator',I4,
5701      &         ' not available - program stopped')
5702          STOP
5703       ENDIF
5704
5705       RETURN
5706
5707  9999 CONTINUE
5708       IREJ = 1
5709       RETURN
5710       END
5711
5712 *$ CREATE DT_CHKCEN.FOR
5713 *COPY DT_CHKCEN
5714 *
5715 *===chkcen=============================================================*
5716 *
5717       SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5718
5719 ************************************************************************
5720 * Check of number of involved projectile nucleons if central production*
5721 * is requested.                                                        *
5722 * Adopted from a part of the old KKEVT routine which was written by    *
5723 * J. Ranft/H.-J.Moehring.                                              *
5724 * This version dated 13.01.95 is written by S. Roesler                 *
5725 ************************************************************************
5726
5727       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5728       SAVE
5729
5730       PARAMETER ( LINP = 10 ,
5731      &            LOUT = 6 ,
5732      &            LDAT = 9 )
5733
5734 * statistics
5735       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5736      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5737      &                ICEVTG(8,0:30)
5738
5739 * central particle production, impact parameter biasing
5740       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5741
5742       IBACK = 0
5743
5744 * old version
5745       IF (ICENTR.EQ.2) THEN
5746          IF (IP.LT.IT) THEN
5747             IF (IP.LE.8) THEN
5748                IF (NP.LT.IP-1) IBACK = 1
5749             ELSEIF (IP.LE.16) THEN
5750                IF (NP.LT.IP-2) IBACK = 1
5751             ELSEIF (IP.LE.32) THEN
5752                IF (NP.LT.IP-3) IBACK = 1
5753             ELSEIF (IP.GE.33) THEN
5754                IF (NP.LT.IP-5) IBACK = 1
5755             ENDIF
5756          ELSEIF (IP.EQ.IT) THEN
5757             IF (IP.EQ.32) THEN
5758                IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5759             ELSE
5760                IF (NP.LT.IP-IP/8) IBACK = 1
5761             ENDIF
5762          ELSEIF (ABS(IP-IT).LT.3) THEN
5763             IF (NP.LT.IP-IP/8) IBACK = 1
5764          ENDIF
5765       ELSE
5766 * new version (DPMJET, 5.6.99)
5767          IF (IP.LT.IT) THEN
5768             IF (IP.LE.8) THEN
5769                IF (NP.LT.IP-1) IBACK = 1
5770             ELSEIF (IP.LE.16) THEN
5771                IF (NP.LT.IP-2) IBACK = 1
5772             ELSEIF (IP.LT.32) THEN
5773                IF (NP.LT.IP-3) IBACK = 1
5774             ELSEIF (IP.GE.32) THEN
5775                IF (IT.LE.150) THEN
5776 *   Example: S-Ag
5777                   IF (NP.LT.IP-1) IBACK = 1
5778                ELSE
5779 *   Example: S-Au
5780                   IF (NP.LT.IP) IBACK = 1
5781                ENDIF
5782             ENDIF
5783          ELSEIF (IP.EQ.IT) THEN
5784 *   Example: S-S
5785            IF (IP.EQ.32) THEN
5786               IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5787 *   Example: Pb-Pb
5788            ELSE
5789               IF (NP.LT.IP-IP/4) IBACK = 1
5790            ENDIF
5791          ELSEIF (ABS(IP-IT).LT.3) THEN
5792             IF (NP.LT.IP-IP/8) IBACK = 1
5793          ENDIF
5794       ENDIF
5795
5796       ICCPRO = ICCPRO+1
5797
5798       RETURN
5799       END
5800
5801 *$ CREATE DT_ININUC.FOR
5802 *COPY DT_ININUC
5803 *
5804 *===ininuc=============================================================*
5805 *
5806       SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5807
5808 ************************************************************************
5809 * Samples initial configuration of nucleons in nucleus with mass NMASS *
5810 * including Fermi-momenta (if reqested).                               *
5811 *          ID             BAMJET-code for hadrons (instead of nuclei)  *
5812 *          NMASS          mass number of nucleus (number of nucleons)  *
5813 *          NCH            charge of nucleus                            *
5814 *          COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5815 *          JS(NMASS) > 0  nucleon undergoes nucleon-nucleon interact.  *
5816 *          IMODE = 1      projectile nucleus                           *
5817 *                = 2      target     nucleus                           *
5818 *                = 3      target     nucleus (E_lab<E_thr for HADRIN)  *
5819 * Adopted from a part of the old KKEVT routine which was written by    *
5820 * J. Ranft/H.-J.Moehring.                                              *
5821 * This version dated 13.01.95 is written by S. Roesler                 *
5822 ************************************************************************
5823
5824       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5825       SAVE
5826
5827       PARAMETER ( LINP = 10 ,
5828      &            LOUT = 6 ,
5829      &            LDAT = 9 )
5830
5831       PARAMETER (FM2MM=1.0D-12)
5832
5833       PARAMETER ( MAXNCL = 260,
5834
5835      &            MAXVQU = MAXNCL,
5836      &            MAXSQU = 20*MAXVQU,
5837      &            MAXINT = MAXVQU+MAXSQU)
5838
5839 * event history
5840
5841       PARAMETER (NMXHKK=200000)
5842
5843       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5844      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5845      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5846
5847 * extended event history
5848       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5849      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5850      &                IHIST(2,NMXHKK)
5851
5852 * flags for input different options
5853       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5854       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5855      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5856
5857 * auxiliary common for chain system storage (DTUNUC 1.x)
5858       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5859
5860 * nuclear potential
5861       LOGICAL LFERMI
5862       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5863      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5864      &                ETACOU(2),ICOUL,LFERMI
5865
5866 * properties of photon/lepton projectiles
5867       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5868
5869 * particle properties (BAMJET index convention)
5870       CHARACTER*8  ANAME
5871       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5872      &                IICH(210),IIBAR(210),K1(210),K2(210)
5873
5874 * Glauber formalism: collision properties
5875       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5876      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5877
5878 * flavors of partons (DTUNUC 1.x)
5879       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5880      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5881      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5882      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5883      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5884      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5885      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5886
5887 * interface HADRIN-DPM
5888       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5889
5890       DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5891
5892 * number of neutrons
5893       NNEU = NMASS-NCH
5894 * initializations
5895       NP = 0
5896       NN = 0
5897       DO 1 K=1,4
5898          PFTOT(K) = 0.0D0
5899     1 CONTINUE
5900       MODE   = IMODE
5901       IF (IMODE.GT.2) MODE = 2
5902 **sr 29.5. new NPOINT(1)-definition
5903 C     IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5904 **
5905       NHADRI = 0
5906       NC     = NHKK
5907
5908 * get initial configuration
5909       DO 2 I=1,NMASS
5910          NHKK = NHKK+1
5911          IF (JS(I).GT.0) THEN
5912             ISTHKK(NHKK) = 10+MODE
5913             IF (IMODE.EQ.3) THEN
5914 *   additional treatment if HADRIN-generator is requested
5915                NHADRI = NHADRI+1
5916                IF (NHADRI.EQ.1) IDXTA  = NHKK
5917                IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5918             ENDIF
5919          ELSE
5920             ISTHKK(NHKK) = 12+MODE
5921          ENDIF
5922          IF (NMASS.GE.2) THEN
5923 *   treatment for nuclei
5924             FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5925             RR   = DT_RNDM(FRAC)
5926             IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5927                IDX = 8
5928                NN  = NN+1
5929             ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5930                IDX = 1
5931                NP  = NP+1
5932             ELSEIF (NN.LT.NNEU) THEN
5933                IDX = 8
5934                NN  = NN+1
5935             ELSEIF (NP.LT.NCH)  THEN
5936                IDX = 1
5937                NP  = NP+1
5938             ENDIF
5939             IDHKK(NHKK) = IDT_IPDGHA(IDX)
5940             IDBAM(NHKK) = IDX
5941             IF (MODE.EQ.1) THEN
5942                IPOSP(I)  = NHKK
5943                KKPROJ(I) = IDX
5944             ELSE
5945                IPOST(I)  = NHKK
5946                KKTARG(I) = IDX
5947             ENDIF
5948             IF (IDX.EQ.1) THEN
5949                PFER = PFERMP(MODE)
5950                PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5951             ELSE
5952                PFER = PFERMN(MODE)
5953                PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5954             ENDIF
5955             CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5956             DO 3 K=1,4
5957                PFTOT(K) = PFTOT(K)+PF(K)
5958                PHKK(K,NHKK) = PF(K)
5959     3       CONTINUE
5960             PHKK(5,NHKK) = AAM(IDX)
5961          ELSE
5962 *   treatment for hadrons
5963             IDHKK(NHKK)  = IDT_IPDGHA(ID)
5964             IDBAM(NHKK)  = ID
5965             PHKK(4,NHKK) = AAM(ID)
5966             PHKK(5,NHKK) = AAM(ID)
5967 C* VDM assumption
5968 C            IF (IDHKK(NHKK).EQ.22) THEN
5969 C               PHKK(4,NHKK) = AAM(33)
5970 C               PHKK(5,NHKK) = AAM(33)
5971 C            ENDIF
5972             IF (MODE.EQ.1) THEN
5973                IPOSP(I)  = NHKK
5974                KKPROJ(I) = ID
5975                PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5976             ELSE
5977                IPOST(I)  = NHKK
5978                KKTARG(I) = ID
5979             ENDIF
5980          ENDIF
5981          DO 4 K=1,3
5982             VHKK(K,NHKK) = COORD(K,I)*FM2MM
5983             WHKK(K,NHKK) = COORD(K,I)*FM2MM
5984     4    CONTINUE
5985          IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5986          IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5987          VHKK(4,NHKK) = 0.0D0
5988          WHKK(4,NHKK) = 0.0D0
5989     2 CONTINUE
5990
5991 * balance Fermi-momenta
5992       IF (NMASS.GE.2) THEN
5993          DO 5 I=1,NMASS
5994             NC = NC+1
5995             DO 6 K=1,3
5996                PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5997     6       CONTINUE
5998             PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5999      &                        PHKK(2,NC)**2+PHKK(3,NC)**2)
6000     5    CONTINUE
6001       ENDIF
6002
6003       RETURN
6004       END
6005
6006 *$ CREATE DT_FER4M.FOR
6007 *COPY DT_FER4M
6008 *
6009 *===fer4m==============================================================*
6010 *
6011       SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
6012
6013 ************************************************************************
6014 * Sampling of nucleon Fermi-momenta from distributions at T=0.         *
6015 *                                   processed by S. Roesler, 17.10.95  *
6016 ************************************************************************
6017
6018       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6019       SAVE
6020
6021       PARAMETER ( LINP = 10 ,
6022      &            LOUT = 6 ,
6023      &            LDAT = 9 )
6024
6025       LOGICAL LSTART
6026
6027 * particle properties (BAMJET index convention)
6028       CHARACTER*8  ANAME
6029       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6030      &                IICH(210),IIBAR(210),K1(210),K2(210)
6031
6032 * nuclear potential
6033       LOGICAL LFERMI
6034       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
6035      &                EBINDP(2),EBINDN(2),EPOT(2,210),
6036      &                ETACOU(2),ICOUL,LFERMI
6037
6038       DATA LSTART /.TRUE./
6039
6040       ILOOP = 0
6041       IF (LFERMI) THEN
6042          IF (LSTART) THEN
6043             WRITE(LOUT,1000)
6044  1000       FORMAT(/,1X,'FER4M:   sampling of Fermi-momenta activated')
6045             LSTART = .FALSE.
6046          ENDIF
6047     1    CONTINUE
6048          CALL DT_DFERMI(PABS)
6049          PABS = PFERM*PABS
6050 C        IF (PABS.GE.PBIND) THEN
6051 C           ILOOP = ILOOP+1
6052 C           IF (MOD(ILOOP,500).EQ.0) THEN
6053 C              WRITE(LOUT,1001) PABS,PBIND,ILOOP
6054 C1001          FORMAT(1X,'FER4M:    Fermi-mom. corr. for binding',
6055 C    &                ' energy ',2E12.3,I6)
6056 C           ENDIF
6057 C           GOTO 1
6058 C        ENDIF
6059          CALL DT_DPOLI(POLC,POLS)
6060          CALL DT_DSFECF(SFE,CFE)
6061          CXTA = POLS*CFE
6062          CYTA = POLS*SFE
6063          CZTA = POLC
6064          ET   = SQRT(PABS*PABS+AAM(KT)**2)
6065          PXT  = CXTA*PABS
6066          PYT  = CYTA*PABS
6067          PZT  = CZTA*PABS
6068       ELSE
6069          ET   = AAM(KT)
6070          PXT  = 0.0D0
6071          PYT  = 0.0D0
6072          PZT  = 0.0D0
6073       ENDIF
6074
6075       RETURN
6076       END
6077
6078 *$ CREATE DT_NUC2CM.FOR
6079 *COPY DT_NUC2CM
6080 *
6081 *===nuc2cm=============================================================*
6082 *
6083       SUBROUTINE DT_NUC2CM
6084
6085 ************************************************************************
6086 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.-   *
6087 * nucl. cms. (This subroutine replaces NUCMOM.)                        *
6088 * This version dated 15.01.95 is written by S. Roesler                 *
6089 ************************************************************************
6090
6091       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6092       SAVE
6093
6094       PARAMETER ( LINP = 10 ,
6095      &            LOUT = 6 ,
6096      &            LDAT = 9 )
6097
6098       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
6099
6100 * event history
6101
6102       PARAMETER (NMXHKK=200000)
6103
6104       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6105      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6106      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6107
6108 * extended event history
6109       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6110      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6111      &                IHIST(2,NMXHKK)
6112
6113 * statistics
6114       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6115      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6116      &                ICEVTG(8,0:30)
6117
6118 * properties of photon/lepton projectiles
6119       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
6120
6121 * particle properties (BAMJET index convention)
6122       CHARACTER*8  ANAME
6123       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6124      &                IICH(210),IIBAR(210),K1(210),K2(210)
6125
6126 * Glauber formalism: collision properties
6127       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
6128      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
6129 **temporary
6130
6131 * statistics: Glauber-formalism
6132       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
6133 **
6134
6135       ICWP = 0
6136       ICWT = 0
6137       NWTACC = 0
6138       NWAACC = 0
6139       NWBACC = 0
6140
6141       NPOINT(1) = NHKK+1
6142       NEND      = NHKK
6143       DO 1 I=1,NEND
6144          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
6145             IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
6146             IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
6147             MODE = ISTHKK(I)-9
6148 C            IF (IDHKK(I).EQ.22) THEN
6149 C* VDM assumption
6150 C               PEIN = AAM(33)
6151 C               IDB  = 33
6152 C            ELSE
6153 C               PEIN = PHKK(4,I)
6154 C               IDB  = IDBAM(I)
6155 C            ENDIF
6156 C            CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
6157 C     &           PX,PY,PZ,PE,IDB,MODE)
6158             IF (PHKK(5,I).GT.ZERO) THEN
6159                CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
6160      &              PX,PY,PZ,PE,IDBAM(I),MODE)
6161             ELSE
6162                PX = PGAMM(1)
6163                PY = PGAMM(2)
6164                PZ = PGAMM(3)
6165                PE = PGAMM(4)
6166             ENDIF
6167             IST = ISTHKK(I)-2
6168             ID  = IDHKK(I)
6169 C* VDM assumption
6170 C            IF (ID.EQ.22) ID = 113
6171             CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
6172             IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
6173             IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
6174          ENDIF
6175     1 CONTINUE
6176
6177       NWTACC = MAX(NWAACC,NWBACC)
6178       ICDPR  = ICDPR+ICWP
6179       ICDTA  = ICDTA+ICWT
6180 **temporary
6181       IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
6182          CALL DT_EVTOUT(4)
6183          STOP
6184       ENDIF
6185
6186       RETURN
6187       END
6188
6189 *$ CREATE DT_SPLPTN.FOR
6190 *COPY DT_SPLPTN
6191 *
6192 *===splptn=============================================================*
6193 *
6194       SUBROUTINE DT_SPLPTN(NN)
6195
6196 ************************************************************************
6197 * SamPLing of ParToN momenta and flavors.                              *
6198 * This version dated 15.01.95 is written by S. Roesler                 *
6199 ************************************************************************
6200
6201       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6202       SAVE
6203
6204       PARAMETER ( LINP = 10 ,
6205      &            LOUT = 6 ,
6206      &            LDAT = 9 )
6207
6208 * Lorentz-parameters of the current interaction
6209       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
6210      &                UMO,PPCM,EPROJ,PPROJ
6211
6212 * sample flavors of sea-quarks
6213       CALL DT_SPLFLA(NN,1)
6214
6215 * sample x-values of partons at chain ends
6216       ECM = UMO
6217       CALL DT_XKSAMP(NN,ECM)
6218
6219 * samle flavors
6220       CALL DT_SPLFLA(NN,2)
6221
6222       RETURN
6223       END
6224
6225 *$ CREATE DT_SPLFLA.FOR
6226 *COPY DT_SPLFLA
6227 *
6228 *===splfla=============================================================*
6229 *
6230       SUBROUTINE DT_SPLFLA(NN,MODE)
6231
6232 ************************************************************************
6233 * SamPLing of FLAvors of partons at chain ends.                        *
6234 * This subroutine replaces FLKSAA/FLKSAM.                              *
6235 *            NN            number of nucleon-nucleon interactions      *
6236 *            MODE = 1      sea-flavors                                 *
6237 *                 = 2      valence-flavors                             *
6238 * Based on the original version written by J. Ranft/H.-J. Moehring.    *
6239 * This version dated 16.01.95 is written by S. Roesler                 *
6240 ************************************************************************
6241
6242       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6243       SAVE
6244
6245       PARAMETER ( LINP = 10 ,
6246      &            LOUT = 6 ,
6247      &            LDAT = 9 )
6248
6249       PARAMETER ( MAXNCL = 260,
6250
6251      &            MAXVQU = MAXNCL,
6252      &            MAXSQU = 20*MAXVQU,
6253      &            MAXINT = MAXVQU+MAXSQU)
6254
6255 * flavors of partons (DTUNUC 1.x)
6256       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6257      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6258      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
6259      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6260      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
6261      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6262      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
6263
6264 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6265       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6266      &                IXPV,IXPS,IXTV,IXTS,
6267      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
6268      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
6269      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
6270      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
6271      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
6272      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
6273      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
6274      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
6275
6276 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6277       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6278      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6279
6280 * particle properties (BAMJET index convention)
6281       CHARACTER*8  ANAME
6282       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6283      &                IICH(210),IIBAR(210),K1(210),K2(210)
6284
6285 * various options for treatment of partons (DTUNUC 1.x)
6286 * (chain recombination, Cronin,..)
6287       LOGICAL LCO2CR,LINTPT
6288       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6289      &                LCO2CR,LINTPT
6290
6291       IF (MODE.EQ.1) THEN
6292 * sea-flavors
6293          DO 1 I=1,NN
6294             IPSQ(I)  = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6295             IPSAQ(I) = -IPSQ(I)
6296     1    CONTINUE
6297          DO 2 I=1,NN
6298             ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6299             ITSAQ(I)= -ITSQ(I)
6300     2    CONTINUE
6301       ELSEIF (MODE.EQ.2) THEN
6302 * valence flavors
6303          DO 3 I=1,IXPV
6304             CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
6305     3    CONTINUE
6306          DO 4 I=1,IXTV
6307             CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
6308     4    CONTINUE
6309       ENDIF
6310
6311       RETURN
6312       END
6313
6314 *$ CREATE DT_GETPTN.FOR
6315 *COPY DT_GETPTN
6316 *
6317 *===getptn=============================================================*
6318 *
6319       SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
6320
6321 ************************************************************************
6322 * This subroutine collects partons at chain ends from temporary        *
6323 * commons and puts them into DTEVT1.                                   *
6324 * This version dated 15.01.95 is written by S. Roesler                 *
6325 ************************************************************************
6326
6327       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6328       SAVE
6329
6330       PARAMETER ( LINP = 10 ,
6331      &            LOUT = 6 ,
6332      &            LDAT = 9 )
6333
6334       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
6335
6336       LOGICAL LCHK
6337
6338       PARAMETER ( MAXNCL = 260,
6339
6340      &            MAXVQU = MAXNCL,
6341      &            MAXSQU = 20*MAXVQU,
6342      &            MAXINT = MAXVQU+MAXSQU)
6343
6344 * event history
6345
6346       PARAMETER (NMXHKK=200000)
6347
6348       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6349      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6350      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6351
6352 * extended event history
6353       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6354      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6355      &                IHIST(2,NMXHKK)
6356
6357 * flags for input different options
6358       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6359       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6360      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6361
6362 * auxiliary common for chain system storage (DTUNUC 1.x)
6363       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
6364
6365 * statistics
6366       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6367      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6368      &                ICEVTG(8,0:30)
6369
6370 * flags for diffractive interactions (DTUNUC 1.x)
6371       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6372
6373 * x-values of partons (DTUNUC 1.x)
6374       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
6375      &                XTVQ(MAXVQU),XTVD(MAXVQU),
6376      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
6377      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
6378
6379 * flavors of partons (DTUNUC 1.x)
6380       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6381      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6382      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
6383      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6384      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
6385      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6386      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
6387
6388 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6389       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6390      &                IXPV,IXPS,IXTV,IXTS,
6391      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
6392      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
6393      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
6394      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
6395      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
6396      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
6397      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
6398      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
6399
6400 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6401       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6402      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6403
6404       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6405
6406       DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6407
6408       IREJ      = 0
6409       NCSY      = 0
6410       NPOINT(2) = NHKK+1
6411
6412 * sea-sea chains
6413       DO 10 I=1,NSS
6414          IF (ISKPCH(1,I).EQ.99) GOTO 10
6415          ICCHAI(1,1) = ICCHAI(1,1)+2
6416          IDXP = INTSS1(I)
6417          IDXT = INTSS2(I)
6418          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6419          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6420          DO 11 K=1,4
6421             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6422             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6423             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6424             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6425    11    CONTINUE
6426          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6427      &                                  +(PP1(3)+PT1(3))**2)
6428          ECH   = PP1(4)+PT1(4)
6429          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6430          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6431      &                                  +(PP2(3)+PT2(3))**2)
6432          ECH   = PP2(4)+PT2(4)
6433          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6434          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6435             AM1 = SQRT(AM1)
6436             AM2 = SQRT(AM2)
6437             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6438 C              WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6439  5000          FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6440             ENDIF
6441          ELSE
6442             WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6443          ENDIF
6444          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6445          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6446          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6447          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6448          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6449      &                                                    0,0,1)
6450          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6451      &                                                    0,0,1)
6452          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6453      &                                                    0,0,1)
6454          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6455      &                                                    0,0,1)
6456          NCSY = NCSY+1
6457    10 CONTINUE
6458
6459 * disea-sea chains
6460       DO 20 I=1,NDS
6461          IF (ISKPCH(2,I).EQ.99) GOTO 20
6462          ICCHAI(1,2) = ICCHAI(1,2)+2
6463          IDXP = INTDS1(I)
6464          IDXT = INTDS2(I)
6465          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6466          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6467          DO 21 K=1,4
6468             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6469             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6470             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6471             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6472    21    CONTINUE
6473          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6474      &                                  +(PP1(3)+PT1(3))**2)
6475          ECH   = PP1(4)+PT1(4)
6476          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6477          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6478      &                                  +(PP2(3)+PT2(3))**2)
6479          ECH   = PP2(4)+PT2(4)
6480          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6481          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6482             AM1 = SQRT(AM1)
6483             AM2 = SQRT(AM2)
6484             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6485 C              WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6486  5001          FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6487             ENDIF
6488          ELSE
6489             WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6490          ENDIF
6491          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6492          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6493          IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6494          IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6495          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6496      &                                                    0,0,2)
6497          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6498      &                                                    0,0,2)
6499          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6500      &                                                    0,0,2)
6501          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6502      &                                                    0,0,2)
6503          NCSY = NCSY+1
6504    20 CONTINUE
6505
6506 * sea-disea chains
6507       DO 30 I=1,NSD
6508          IF (ISKPCH(3,I).EQ.99) GOTO 30
6509          ICCHAI(1,3) = ICCHAI(1,3)+2
6510          IDXP = INTSD1(I)
6511          IDXT = INTSD2(I)
6512          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6513          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6514          DO 31 K=1,4
6515             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6516             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6517             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6518             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6519    31    CONTINUE
6520          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6521      &                                  +(PP1(3)+PT1(3))**2)
6522          ECH   = PP1(4)+PT1(4)
6523          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6524          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6525      &                                  +(PP2(3)+PT2(3))**2)
6526          ECH   = PP2(4)+PT2(4)
6527          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6528          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6529             AM1 = SQRT(AM1)
6530             AM2 = SQRT(AM2)
6531             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6532 C              WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6533  5002          FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6534             ENDIF
6535          ELSE
6536             WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6537          ENDIF
6538          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6539          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6540          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6541          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6542          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6543      &                                                    0,0,3)
6544          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6545      &                                                    0,0,3)
6546          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6547      &                                                    0,0,3)
6548          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6549      &                                                    0,0,3)
6550          NCSY = NCSY+1
6551    30 CONTINUE
6552
6553 * disea-valence chains
6554       DO 50 I=1,NDV
6555          IF (ISKPCH(5,I).EQ.99) GOTO 50
6556          ICCHAI(1,5) = ICCHAI(1,5)+2
6557          IDXP = INTDV1(I)
6558          IDXT = INTDV2(I)
6559          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6560          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6561          DO 51 K=1,4
6562             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6563             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6564             PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6565             PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6566    51    CONTINUE
6567          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6568      &                                  +(PP1(3)+PT1(3))**2)
6569          ECH   = PP1(4)+PT1(4)
6570          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6571          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6572      &                                  +(PP2(3)+PT2(3))**2)
6573          ECH   = PP2(4)+PT2(4)
6574          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6575          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6576             AM1 = SQRT(AM1)
6577             AM2 = SQRT(AM2)
6578             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6579 C              WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6580  5003          FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6581             ENDIF
6582          ELSE
6583             WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6584          ENDIF
6585          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6586          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6587          IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6588          IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6589          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6590      &                                                    0,0,5)
6591          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6592      &                                                    0,0,5)
6593          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6594      &                                                    0,0,5)
6595          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6596      &                                                    0,0,5)
6597          NCSY = NCSY+1
6598    50 CONTINUE
6599
6600 * valence-sea chains
6601       DO 60 I=1,NVS
6602          IF (ISKPCH(6,I).EQ.99) GOTO 60
6603          ICCHAI(1,6) = ICCHAI(1,6)+2
6604          IDXP = INTVS1(I)
6605          IDXT = INTVS2(I)
6606          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6607          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6608          DO 61 K=1,4
6609             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6610             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6611             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6612             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6613    61    CONTINUE
6614          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6615          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6616          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6617          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6618          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6619          IF (LCHK) THEN
6620             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6621      &                                                       0,0,6)
6622             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6623      &                                                       0,0,6)
6624             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6625      &                                                       0,0,6)
6626             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6627      &                                                       0,0,6)
6628             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6629      &                                     +(PP1(3)+PT1(3))**2)
6630             ECH   = PP1(4)+PT1(4)
6631             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6632             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6633      &                                     +(PP2(3)+PT2(3))**2)
6634             ECH   = PP2(4)+PT2(4)
6635             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6636          ELSE
6637             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6638      &                                                       0,0,6)
6639             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6640      &                                                       0,0,6)
6641             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6642      &                                                       0,0,6)
6643             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6644      &                                                       0,0,6)
6645             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6646      &                                     +(PP1(3)+PT2(3))**2)
6647             ECH   = PP1(4)+PT2(4)
6648             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6649             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6650      &                                     +(PP2(3)+PT1(3))**2)
6651             ECH   = PP2(4)+PT1(4)
6652             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6653          ENDIF
6654          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6655             AM1 = SQRT(AM1)
6656             AM2 = SQRT(AM2)
6657             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6658 C              WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6659  5004          FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6660             ENDIF
6661          ELSE
6662             WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6663          ENDIF
6664          NCSY = NCSY+1
6665    60 CONTINUE
6666
6667 * sea-valence chains
6668       DO 40 I=1,NSV
6669          IF (ISKPCH(4,I).EQ.99) GOTO 40
6670          ICCHAI(1,4) = ICCHAI(1,4)+2
6671          IDXP = INTSV1(I)
6672          IDXT = INTSV2(I)
6673          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6674          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6675          DO 41 K=1,4
6676             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6677             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6678             PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6679             PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6680    41    CONTINUE
6681          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6682      &                                  +(PP1(3)+PT1(3))**2)
6683          ECH   = PP1(4)+PT1(4)
6684          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6685          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6686      &                                  +(PP2(3)+PT2(3))**2)
6687          ECH   = PP2(4)+PT2(4)
6688          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6689          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6690             AM1 = SQRT(AM1)
6691             AM2 = SQRT(AM2)
6692             IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6693 C              WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6694  5005          FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6695             ENDIF
6696          ELSE
6697             WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6698          ENDIF
6699          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6700          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6701          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6702          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6703          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6704      &                                                    0,0,4)
6705          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6706      &                                                    0,0,4)
6707          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6708      &                                                    0,0,4)
6709          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6710      &                                                    0,0,4)
6711          NCSY = NCSY+1
6712    40 CONTINUE
6713
6714 * valence-disea chains
6715       DO 70 I=1,NVD
6716          IF (ISKPCH(7,I).EQ.99) GOTO 70
6717          ICCHAI(1,7) = ICCHAI(1,7)+2
6718          IDXP = INTVD1(I)
6719          IDXT = INTVD2(I)
6720          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6721          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6722          DO 71 K=1,4
6723             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6724             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6725             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6726             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6727    71    CONTINUE
6728          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6729          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6730          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6731          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6732          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6733          IF (LCHK) THEN
6734             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6735      &                                                       0,0,7)
6736             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6737      &                                                       0,0,7)
6738             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6739      &                                                       0,0,7)
6740             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6741      &                                                       0,0,7)
6742             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6743      &                                     +(PP1(3)+PT1(3))**2)
6744             ECH   = PP1(4)+PT1(4)
6745             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6746             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6747      &                                     +(PP2(3)+PT2(3))**2)
6748             ECH   = PP2(4)+PT2(4)
6749             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6750          ELSE
6751             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6752      &                                                       0,0,7)
6753             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6754      &                                                       0,0,7)
6755             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6756      &                                                       0,0,7)
6757             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6758      &                                                       0,0,7)
6759             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6760      &                                     +(PP1(3)+PT2(3))**2)
6761             ECH   = PP1(4)+PT2(4)
6762             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6763             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6764      &                                     +(PP2(3)+PT1(3))**2)
6765             ECH   = PP2(4)+PT1(4)
6766             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6767          ENDIF
6768          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6769             AM1 = SQRT(AM1)
6770             AM2 = SQRT(AM2)
6771             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6772 C              WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6773  5006          FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6774             ENDIF
6775          ELSE
6776             WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6777          ENDIF
6778          NCSY = NCSY+1
6779    70 CONTINUE
6780
6781 * valence-valence chains
6782       DO 80 I=1,NVV
6783          IF (ISKPCH(8,I).EQ.99) GOTO 80
6784          ICCHAI(1,8) = ICCHAI(1,8)+2
6785          IDXP = INTVV1(I)
6786          IDXT = INTVV2(I)
6787          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6788          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6789          DO 81 K=1,4
6790             PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6791             PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6792             PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6793             PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6794    81    CONTINUE
6795          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6796          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6797          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6798          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6799
6800 * check for diffractive event
6801          IDIFF = 0
6802          IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6803      &        (IP.EQ.1).AND.(NN.EQ.1)) THEN
6804             DO 800 K=1,4
6805                PP(K) = PP1(K)+PP2(K)
6806                PT(K) = PT1(K)+PT2(K)
6807   800       CONTINUE
6808             ISTCK = NHKK
6809             CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6810      &                  IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6811 C           IF (IREJ1.NE.0) GOTO 9999
6812             IF (IREJ1.NE.0) THEN
6813                IDIFF = 0
6814                NHKK  = ISTCK
6815             ENDIF
6816          ELSE
6817             IDIFF = 0
6818          ENDIF
6819
6820          IF (IDIFF.EQ.0) THEN
6821 *   valence-valence chain system
6822             CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6823             IF (LCHK) THEN
6824 *    baryon-baryon
6825                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6826      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6827                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6828      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6829                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6830      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6831                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6832      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6833                PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6834      &                                        +(PP1(3)+PT1(3))**2)
6835                ECH   = PP1(4)+PT1(4)
6836                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6837                PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6838      &                                        +(PP2(3)+PT2(3))**2)
6839                ECH   = PP2(4)+PT2(4)
6840                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6841             ELSE
6842 *    antibaryon-baryon
6843                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6844      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6845                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6846      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6847                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6848      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6849                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6850      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6851                PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6852      &                                        +(PP1(3)+PT2(3))**2)
6853                ECH   = PP1(4)+PT2(4)
6854                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6855                PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6856      &                                        +(PP2(3)+PT1(3))**2)
6857                ECH   = PP2(4)+PT1(4)
6858                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6859             ENDIF
6860             IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6861                AM1 = SQRT(AM1)
6862                AM2 = SQRT(AM2)
6863                IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6864 C                 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6865  5007             FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6866                ENDIF
6867             ELSE
6868                WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6869             ENDIF
6870             NCSY = NCSY+1
6871          ENDIF
6872    80 CONTINUE
6873       IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6874
6875 * energy-momentum & flavor conservation check
6876       IF (ABS(IDIFF).NE.1) THEN
6877          IF (IDIFF.NE.0) THEN
6878             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6879      &                                              1,3,10,IREJ)
6880          ELSE
6881             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6882      &                                              1,3,10,IREJ)
6883          ENDIF
6884          IF (IREJ.NE.0) THEN
6885             CALL DT_EVTOUT(4)
6886             STOP
6887          ENDIF
6888       ENDIF
6889
6890       RETURN
6891
6892  9999 CONTINUE
6893       IREJ  = 1
6894       RETURN
6895       END
6896
6897 *$ CREATE DT_CHKCSY.FOR
6898 *COPY DT_CHKCSY
6899 *
6900 *===chkcsy=============================================================*
6901 *
6902       SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6903
6904 ************************************************************************
6905 * CHeCk Chain SYstem for consistency of partons at chain ends.         *
6906 *            ID1,ID2        PDG-numbers of partons at chain ends       *
6907 *            LCHK = .true.  consistent chain                           *
6908 *                 = .false. inconsistent chain                         *
6909 * This version dated 18.01.95 is written by S. Roesler                 *
6910 ************************************************************************
6911
6912       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6913       SAVE
6914
6915       PARAMETER ( LINP = 10 ,
6916      &            LOUT = 6 ,
6917      &            LDAT = 9 )
6918
6919       LOGICAL LCHK
6920
6921       LCHK = .TRUE.
6922
6923 * q-aq chain
6924       IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6925          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6926 * q-qq, aq-aqaq chain
6927       ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6928      &        ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6929          IF (ID1*ID2.LT.0) LCHK = .FALSE.
6930 * qq-aqaq chain
6931       ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6932          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6933       ENDIF
6934
6935       RETURN
6936       END
6937
6938 *$ CREATE DT_EVENTA.FOR
6939 *COPY DT_EVENTA
6940 *
6941 *===eventa=============================================================*
6942 *
6943       SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6944
6945 ************************************************************************
6946 * Treatment of nucleon-nucleon interactions in a two-chain             *
6947 * approximation.                                                       *
6948 *  (input) ID       BAMJET-index of projectile hadron (in case of      *
6949 *                   h-K scattering)                                    *
6950 *          IP/IT    mass number of projectile/target nucleus           *
6951 *          NCSY     number of two chain systems                        *
6952 *          IREJ     rejection flag                                     *
6953 * This version dated 15.01.95 is written by S. Roesler                 *
6954 ************************************************************************
6955
6956       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6957       SAVE
6958
6959       PARAMETER ( LINP = 10 ,
6960      &            LOUT = 6 ,
6961      &            LDAT = 9 )
6962
6963       PARAMETER (TINY10=1.0D-10)
6964
6965 * event history
6966
6967       PARAMETER (NMXHKK=200000)
6968
6969       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6970      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6971      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6972
6973 * extended event history
6974       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6975      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6976      &                IHIST(2,NMXHKK)
6977
6978 * rejection counter
6979       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6980      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6981      &                IREXCI(3),IRDIFF(2),IRINC
6982
6983 * flags for diffractive interactions (DTUNUC 1.x)
6984       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6985
6986 * particle properties (BAMJET index convention)
6987       CHARACTER*8  ANAME
6988       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6989      &                IICH(210),IIBAR(210),K1(210),K2(210)
6990
6991 * flags for input different options
6992       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6993       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6994      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6995
6996 * various options for treatment of partons (DTUNUC 1.x)
6997 * (chain recombination, Cronin,..)
6998       LOGICAL LCO2CR,LINTPT
6999       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
7000      &                LCO2CR,LINTPT
7001
7002       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
7003
7004       IREJ      = 0
7005       NPOINT(3) = NHKK+1
7006
7007 * skip following treatment for low-mass diffraction
7008       IF (ABS(IFLAGD).EQ.1) THEN
7009          NPOINT(3) = NPOINT(2)
7010          GOTO 5
7011       ENDIF
7012
7013 * multiple scattering of chain ends
7014       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
7015       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
7016
7017       NC = NPOINT(2)
7018 * get a two-chain system from DTEVT1
7019       DO 3 I=1,NCSY
7020          IFP1 = IDHKK(NC)
7021          IFT1 = IDHKK(NC+1)
7022          IFP2 = IDHKK(NC+2)
7023          IFT2 = IDHKK(NC+3)
7024          DO 4 K=1,4
7025             PP1(K) = PHKK(K,NC)
7026             PT1(K) = PHKK(K,NC+1)
7027             PP2(K) = PHKK(K,NC+2)
7028             PT2(K) = PHKK(K,NC+3)
7029     4    CONTINUE
7030          MOP1 = NC
7031          MOT1 = NC+1
7032          MOP2 = NC+2
7033          MOT2 = NC+3
7034          CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
7035      &               IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
7036          IF (IREJ1.GT.0) THEN
7037             IRHHA = IRHHA+1
7038             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
7039             GOTO 9999
7040          ENDIF
7041          NC = NC+4
7042     3 CONTINUE
7043
7044 * meson/antibaryon projectile:
7045 * sample single-chain valence-valence systems (Reggeon contrib.)
7046       IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
7047          IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
7048       ENDIF
7049
7050       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7051 * check DTEVT1 for remaining resonance mass corrections
7052          CALL DT_EVTRES(IREJ1)
7053          IF (IREJ1.GT.0) THEN
7054             IRRES(1) = IRRES(1)+1
7055             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
7056             GOTO 9999
7057          ENDIF
7058       ENDIF
7059
7060 * assign p_t to two-"chain" systems consisting of two resonances only
7061 * since only entries for chains will be affected, this is obsolete
7062 * in case of JETSET-fragmetation
7063       CALL DT_RESPT
7064
7065 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
7066       IF (LCO2CR) CALL DT_COM2CR
7067
7068     5 CONTINUE
7069
7070 * fragmentation of the complete event
7071 **uncomment for internal phojet-fragmentation
7072 C     CALL DT_EVTFRA(IREJ1)
7073       CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
7074       IF (IREJ1.GT.0) THEN
7075          IRFRAG = IRFRAG+1
7076          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
7077          GOTO 9999
7078       ENDIF
7079
7080 * decay of possible resonances (should be obsolete)
7081       CALL DT_DECAY1
7082
7083       RETURN
7084
7085  9999 CONTINUE
7086       IREVT = IREVT+1
7087       IREJ  = 1
7088       RETURN
7089       END
7090
7091 *$ CREATE DT_GETCSY.FOR
7092 *COPY DT_GETCSY
7093 *
7094 *===getcsy=============================================================*
7095 *
7096       SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
7097      &                  IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
7098
7099 ************************************************************************
7100 * This version dated 15.01.95 is written by S. Roesler                 *
7101 ************************************************************************
7102
7103       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7104       SAVE
7105
7106       PARAMETER ( LINP = 10 ,
7107      &            LOUT = 6 ,
7108      &            LDAT = 9 )
7109
7110       PARAMETER (TINY10=1.0D-10)
7111
7112 * event history
7113
7114       PARAMETER (NMXHKK=200000)
7115
7116       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7117      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7118      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7119
7120 * extended event history
7121       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7122      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7123      &                IHIST(2,NMXHKK)
7124
7125 * rejection counter
7126       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7127      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7128      &                IREXCI(3),IRDIFF(2),IRINC
7129
7130 * flags for input different options
7131       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7132       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7133      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7134
7135 * flags for diffractive interactions (DTUNUC 1.x)
7136       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
7137
7138       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
7139      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
7140
7141       IREJ  = 0
7142
7143 * get quark content of partons
7144       DO 1 I=1,2
7145          IFP1(I) = 0
7146          IFP2(I) = 0
7147          IFT1(I) = 0
7148          IFT2(I) = 0
7149     1 CONTINUE
7150       IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
7151       IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
7152       IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
7153       IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
7154       IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
7155       IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
7156       IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
7157       IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
7158
7159 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
7160       IDCH1 = 2
7161       IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
7162       IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
7163       IDCH2 = 2
7164       IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
7165       IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
7166
7167 * store initial configuration for energy-momentum cons. check
7168       IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
7169
7170 * sample intrinsic p_t at chain-ends
7171       CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
7172      &            PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
7173      &            AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
7174       IF (IREJ1.NE.0) THEN
7175          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
7176          IRPT = IRPT+1
7177          GOTO 9999
7178       ENDIF
7179
7180 C      IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7181 C         IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
7182 C* check second chain for resonance
7183 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7184 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
7185 C            IF (IREJ1.NE.0) GOTO 9999
7186 C            IF (IDR2.NE.0) THEN
7187 C               CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7188 C     &                     AMCH2,AMCH2N,AMCH1,IREJ1)
7189 C               IF (IREJ1.NE.0) GOTO 9999
7190 C            ENDIF
7191 C* check first chain for resonance
7192 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7193 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
7194 C            IF (IREJ1.NE.0) GOTO 9999
7195 C            IF (IDR1.NE.0) IDR1 = 100*IDR1
7196 C         ELSE
7197 C* check first chain for resonance
7198 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7199 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
7200 C            IF (IREJ1.NE.0) GOTO 9999
7201 C            IF (IDR1.NE.0) THEN
7202 C               CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7203 C     &                     AMCH1,AMCH1N,AMCH2,IREJ1)
7204 C               IF (IREJ1.NE.0) GOTO 9999
7205 C            ENDIF
7206 C* check second chain for resonance
7207 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7208 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
7209 C            IF (IREJ1.NE.0) GOTO 9999
7210 C            IF (IDR2.NE.0) IDR2 = 100*IDR2
7211 C         ENDIF
7212 C      ENDIF
7213
7214       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7215 * check chains for resonances
7216          CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7217      &               AMCH1,AMCH1N,IDCH1,IREJ1)
7218          IF (IREJ1.NE.0) GOTO 9999
7219          CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7220      &               AMCH2,AMCH2N,IDCH2,IREJ1)
7221          IF (IREJ1.NE.0) GOTO 9999
7222 * change kinematics corresponding to resonance-masses
7223          IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
7224             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7225      &                                 AMCH1,AMCH1N,AMCH2,IREJ1)
7226             IF (IREJ1.GT.0) GOTO 9999
7227             IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7228             CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7229      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
7230             IF (IREJ1.NE.0) GOTO 9999
7231             IF (IDR2.NE.0) IDR2 = 100*IDR2
7232          ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
7233             CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7234      &                                 AMCH2,AMCH2N,AMCH1,IREJ1)
7235             IF (IREJ1.GT.0) GOTO 9999
7236             IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7237             CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7238      &                  AMCH1,AMCH1N,IDCH1,IREJ1)
7239             IF (IREJ1.NE.0) GOTO 9999
7240             IF (IDR1.NE.0) IDR1 = 100*IDR1
7241          ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
7242             AMDIF1 = ABS(AMCH1-AMCH1N)
7243             AMDIF2 = ABS(AMCH2-AMCH2N)
7244             IF (AMDIF2.LT.AMDIF1) THEN
7245                CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7246      &                                    AMCH2,AMCH2N,AMCH1,IREJ1)
7247                IF (IREJ1.GT.0) GOTO 9999
7248                IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7249                CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
7250      &                     IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
7251                IF (IREJ1.NE.0) GOTO 9999
7252                IF (IDR1.NE.0) IDR1 = 100*IDR1
7253             ELSE
7254                CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7255      &                                    AMCH1,AMCH1N,AMCH2,IREJ1)
7256                IF (IREJ1.GT.0) GOTO 9999
7257                IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7258                CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
7259      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
7260                IF (IREJ1.NE.0) GOTO 9999
7261                IF (IDR2.NE.0) IDR2 = 100*IDR2
7262             ENDIF
7263          ENDIF
7264       ENDIF
7265
7266 * store final configuration for energy-momentum cons. check
7267       IF (LEMCCK) THEN
7268          CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
7269          CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
7270          IF (IREJ1.NE.0) GOTO 9999
7271       ENDIF
7272
7273 * put partons and chains into DTEVT1
7274       DO 10 I=1,4
7275          PCH1(I) = PP1(I)+PT1(I)
7276          PCH2(I) = PP2(I)+PT2(I)
7277    10 CONTINUE
7278       CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
7279      &                                      PP1(3),PP1(4),0,0,0)
7280       CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
7281      &                                      PT1(3),PT1(4),0,0,0)
7282       KCH = 100+IDCH(MOP1)*10+1
7283       CALL DT_EVTPUT(KCH,88888,-2,-1,
7284      &           PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
7285       CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
7286      &                                      PP2(3),PP2(4),0,0,0)
7287       CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
7288      &                                      PT2(3),PT2(4),0,0,0)
7289       KCH = KCH+1
7290       CALL DT_EVTPUT(KCH,88888,-2,-1,
7291      &           PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
7292
7293       RETURN
7294
7295  9999 CONTINUE
7296       IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
7297 * "cancel" sea-sea chains
7298          CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
7299          IF (IREJ1.NE.0) GOTO 9998
7300 **sr 16.5. flag for EVENTB
7301          IREJ = -1
7302          RETURN
7303       ENDIF
7304  9998 CONTINUE
7305       IREJ = 1
7306       RETURN
7307       END
7308
7309 *$ CREATE DT_CHKINE.FOR
7310 *COPY DT_CHKINE
7311 *
7312 *===chkine=============================================================*
7313 *
7314       SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
7315      &                  AMCH1,AMCH1N,AMCH2,IREJ)
7316
7317 ************************************************************************
7318 * This subroutine replaces CORMOM.                                     *
7319 * This version dated 05.01.95 is written by S. Roesler                 *
7320 ************************************************************************
7321
7322       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7323       SAVE
7324
7325       PARAMETER ( LINP = 10 ,
7326      &            LOUT = 6 ,
7327      &            LDAT = 9 )
7328
7329       PARAMETER (TINY10=1.0D-10)
7330
7331 * flags for input different options
7332       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7333       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7334      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7335
7336 * rejection counter
7337       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7338      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7339      &                IREXCI(3),IRDIFF(2),IRINC
7340
7341       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
7342      &          PP1I(4),PP2I(4),PT1I(4),PT2I(4)
7343
7344       IREJ  = 0
7345       JMSHL = IMSHL
7346
7347       SCALE  = AMCH1N/MAX(AMCH1,TINY10)
7348       DO 10 I=1,4
7349          PP1(I) = PP1I(I)
7350          PP2(I) = PP2I(I)
7351          PT1(I) = PT1I(I)
7352          PT2(I) = PT2I(I)
7353          PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
7354          PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
7355          PP1(I) = SCALE*PP1(I)
7356          PT1(I) = SCALE*PT1(I)
7357    10 CONTINUE
7358       IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
7359      &    (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
7360
7361       ECH = PP2(4)+PT2(4)
7362       PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
7363      &                               (PP2(3)+PT2(3))**2 )
7364       AMCH22 = (ECH-PCH)*(ECH+PCH)
7365       IF (AMCH22.LT.0.0D0) THEN
7366          IF (IOULEV(1).GT.0)
7367      &      WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
7368          GOTO 9997
7369       ENDIF
7370
7371       AMCH1 = AMCH1N
7372       AMCH2 = SQRT(AMCH22)
7373
7374 * put partons again on mass shell
7375    13 CONTINUE
7376       XM1 = 0.0D0
7377       XM2 = 0.0D0
7378       IF (JMSHL.EQ.1) THEN
7379
7380          XM1 = PYMASS(IFP1)
7381          XM2 = PYMASS(IFT1)
7382
7383       ENDIF
7384       CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
7385       IF (IREJ1.NE.0) THEN
7386          IF (JMSHL.EQ.0) GOTO 9998
7387          JMSHL = 0
7388          GOTO 13
7389       ENDIF
7390       JMSHL = IMSHL
7391       DO 11 I=1,4
7392          PP1(I) = P1(I)
7393          PT1(I) = P2(I)
7394    11 CONTINUE
7395    14 CONTINUE
7396       XM1 = 0.0D0
7397       XM2 = 0.0D0
7398       IF (JMSHL.EQ.1) THEN
7399
7400          XM1 = PYMASS(IFP2)
7401          XM2 = PYMASS(IFT2)
7402
7403       ENDIF
7404       CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
7405       IF (IREJ1.NE.0) THEN
7406          IF (JMSHL.EQ.0) GOTO 9998
7407          JMSHL = 0
7408          GOTO 14
7409       ENDIF
7410       DO 12 I=1,4
7411          PP2(I) = P1(I)
7412          PT2(I) = P2(I)
7413    12 CONTINUE
7414       DO 15 I=1,4
7415          PP1I(I) = PP1(I)
7416          PP2I(I) = PP2(I)
7417          PT1I(I) = PT1(I)
7418          PT2I(I) = PT2(I)
7419    15 CONTINUE
7420       RETURN
7421
7422  9997 IRCHKI(1) = IRCHKI(1)+1
7423 **sr
7424 C     GOTO 9999
7425       IREJ = -1
7426       RETURN
7427 **
7428  9998 IRCHKI(2) = IRCHKI(2)+1
7429
7430  9999 CONTINUE
7431       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7432       IREJ = 1
7433       RETURN
7434       END
7435
7436 *$ CREATE DT_CH2RES.FOR
7437 *COPY DT_CH2RES
7438 *
7439 *===ch2res=============================================================*
7440 *
7441       SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7442      &                  AM,AMN,IMODE,IREJ)
7443
7444 ************************************************************************
7445 * Check chains for resonance production.                               *
7446 * This subroutine replaces COMCMA/COBCMA/COMCM2                        *
7447 *    input:                                                            *
7448 *          IF1,2,3,4    input flavors (q,aq in any order)              *
7449 *          AM           chain mass                                     *
7450 *          MODE = 1     check q-aq chain for meson-resonance           *
7451 *               = 2     check q-qq, aq-aqaq chain for baryon-resonance *
7452 *               = 3     check qq-aqaq chain for lower mass cut         *
7453 *    output:                                                           *
7454 *          IDR = 0      no resonances found                            *
7455 *              = -1     pseudoscalar meson/octet baryon                *
7456 *              = 1      vector-meson/decuplet baryon                   *
7457 *          IDXR         BAMJET-index of corresponding resonance        *
7458 *          AMN          mass of corresponding resonance                *
7459 *                                                                      *
7460 *          IREJ         rejection flag                                 *
7461 * This version dated 06.01.95 is written by S. Roesler                 *
7462 ************************************************************************
7463
7464       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7465       SAVE
7466
7467       PARAMETER ( LINP = 10 ,
7468      &            LOUT = 6 ,
7469      &            LDAT = 9 )
7470
7471 * particle properties (BAMJET index convention)
7472       CHARACTER*8  ANAME
7473       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7474      &                IICH(210),IIBAR(210),K1(210),K2(210)
7475
7476 * quark-content to particle index conversion (DTUNUC 1.x)
7477       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7478      &                IA08(6,21),IA10(6,21)
7479
7480 * rejection counter
7481       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7482      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7483      &                IREXCI(3),IRDIFF(2),IRINC
7484
7485 * flags for input different options
7486       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7487       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7488      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7489
7490       DIMENSION IF(4),JF(4)
7491
7492 **sr 4.7. test
7493 C     DATA AMLOM,AMLOB /0.08D0,0.2D0/
7494       DATA AMLOM,AMLOB /0.1D0,0.7D0/
7495 **
7496 C     DATA AMLOM,AMLOB /0.001D0,0.001D0/
7497
7498       MODE = ABS(IMODE)
7499
7500       IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7501          WRITE(LOUT,1000) MODE
7502  1000    FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7503      &          1X,'        program stopped')
7504          STOP
7505       ENDIF
7506
7507       AMX  = AM
7508       IREJ = 0
7509       IDR  = 0
7510       IDXR = 0
7511       AMN  = AMX
7512       IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7513       IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7514
7515       IF(1) = IF1
7516       IF(2) = IF2
7517       IF(3) = IF3
7518       IF(4) = IF4
7519       NF = 0
7520       DO 100 I=1,4
7521          IF (IF(I).NE.0) THEN
7522             NF = NF+1
7523             JF(NF) = IF(I)
7524          ENDIF
7525   100 CONTINUE
7526       IF (NF.LE.MODE) THEN
7527          WRITE(LOUT,1001) MODE,IF
7528  1001    FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7529      &   I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7530          GOTO 9999
7531       ENDIF
7532
7533       GOTO (1,2,3) MODE
7534
7535 * check for meson resonance
7536     1 CONTINUE
7537       IFQ  = JF(1)
7538       IFAQ = ABS(JF(2))
7539       IF (JF(2).GT.0) THEN
7540          IFQ  = JF(2)
7541          IFAQ = ABS(JF(1))
7542       ENDIF
7543       IFPS = IMPS(IFAQ,IFQ)
7544       IFV  = IMVE(IFAQ,IFQ)
7545       AMPS = AAM(IFPS)
7546       AMV  = AAM(IFV)
7547       AMHI = AMV+0.3D0
7548       IF (AMX.LT.AMV) THEN
7549          IF (AMX.LT.AMPS) THEN
7550             IF (IMODE.GT.0) THEN
7551                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7552             ELSE
7553                IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7554             ENDIF
7555             LOMRES = LOMRES+1
7556          ENDIF
7557 *    replace chain by pseudoscalar meson
7558          IDR  = -1
7559          IDXR = IFPS
7560          AMN  = AMPS
7561       ELSEIF (AMX.LT.AMHI) THEN
7562 *    replace chain by vector-meson
7563          IDR  = 1
7564          IDXR = IFV
7565          AMN  = AMV
7566       ENDIF
7567       RETURN
7568
7569 * check for baryon resonance
7570     2 CONTINUE
7571       CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7572       AM8  = AAM(JB8)
7573       AM10 = AAM(JB10)
7574       AMHI = AM10+0.3D0
7575       IF (AMX.LT.AM10) THEN
7576          IF (AMX.LT.AM8) THEN
7577             IF (IMODE.GT.0) THEN
7578                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7579             ELSE
7580                IF (AMX.LT.0.8D0*AM8) GOTO 9999
7581             ENDIF
7582             LOBRES = LOBRES+1
7583          ENDIF
7584 *    replace chain by oktet baryon
7585          IDR  = -1
7586          IDXR = JB8
7587          AMN  = AM8
7588       ELSEIF (AMX.LT.AMHI) THEN
7589          IDR  = 1
7590          IDXR = JB10
7591          AMN  = AM10
7592       ENDIF
7593       RETURN
7594
7595 * check qq-aqaq for lower mass cut
7596     3 CONTINUE
7597 *   empirical definition of AMHI to allow for (b-antib)-pair prod.
7598       AMHI = 2.5D0
7599       IF (AMX.LT.AMHI) GOTO 9999
7600       RETURN
7601
7602  9999 CONTINUE
7603       IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7604      &    WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7605       IREJ = 1
7606       IRRES(2) = IRRES(2)+1
7607       RETURN
7608       END
7609
7610 *$ CREATE DT_RJSEAC.FOR
7611 *COPY DT_RJSEAC
7612 *
7613 *===rjseac=============================================================*
7614 *
7615       SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7616
7617 ************************************************************************
7618 * ReJection of SEA-sea Chains.                                         *
7619 *         MOP1/2       entries of projectile sea-partons in DTEVT1     *
7620 *         MOT1/2       entries of projectile sea-partons in DTEVT1     *
7621 * This version dated 16.01.95 is written by S. Roesler                 *
7622 ************************************************************************
7623
7624       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7625       SAVE
7626
7627       PARAMETER ( LINP = 10 ,
7628      &            LOUT = 6 ,
7629      &            LDAT = 9 )
7630
7631       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7632
7633 * event history
7634
7635       PARAMETER (NMXHKK=200000)
7636
7637       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7638      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7639      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7640
7641 * extended event history
7642       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7643      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7644      &                IHIST(2,NMXHKK)
7645
7646 * statistics
7647       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7648      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7649      &                ICEVTG(8,0:30)
7650
7651       DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7652
7653       IREJ = 0
7654
7655 * projectile sea q-aq-pair
7656 *    indices of sea-pair
7657       IDXSEA(1,1) = MOP1
7658       IDXSEA(1,2) = MOP2
7659 *    index of mother-nucleon
7660       IDXNUC(1)   = JMOHKK(1,MOP1)
7661 *    status of valence quarks to be corrected
7662       ISTVAL(1)   = -21
7663
7664 * target sea q-aq-pair
7665 *    indices of sea-pair
7666       IDXSEA(2,1) = MOT1
7667       IDXSEA(2,2) = MOT2
7668 *    index of mother-nucleon
7669       IDXNUC(2)   = JMOHKK(1,MOT1)
7670 *    status of valence quarks to be corrected
7671       ISTVAL(2)   = -22
7672
7673       DO 1 N=1,2
7674          IDONE = 0
7675          DO 2 I=NPOINT(2),NHKK
7676             IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7677      &          (JMOHKK(1,I).EQ.IDXNUC(N)))   THEN
7678 * valence parton found
7679 *    inrease 4-momentum by sea 4-momentum
7680                DO 3 K=1,4
7681                   PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7682      &                                  PHKK(K,IDXSEA(N,2))
7683     3          CONTINUE
7684                PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7685      &                              PHKK(2,I)**2-PHKK(3,I)**2))
7686 *    "cancel" sea-pair
7687                DO 4 J=1,2
7688                   ISTHKK(IDXSEA(N,J))   = 100
7689                   IDHKK(IDXSEA(N,J))    = 0
7690                   JMOHKK(1,IDXSEA(N,J)) = 0
7691                   JMOHKK(2,IDXSEA(N,J)) = 0
7692                   JDAHKK(1,IDXSEA(N,J)) = 0
7693                   JDAHKK(2,IDXSEA(N,J)) = 0
7694                   DO 5 K=1,4
7695                      PHKK(K,IDXSEA(N,J)) = ZERO
7696                      VHKK(K,IDXSEA(N,J)) = ZERO
7697                      WHKK(K,IDXSEA(N,J)) = ZERO
7698     5             CONTINUE
7699                   PHKK(5,IDXSEA(N,J)) = ZERO
7700     4          CONTINUE
7701                IDONE = 1
7702             ENDIF
7703     2    CONTINUE
7704          IF (IDONE.NE.1) THEN
7705             WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7706  1000       FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7707      &                '-record!',/,1X,'        sea-quark pairs   ',
7708      &                2I5,4X,2I5,'   could not be canceled!')
7709             GOTO 9999
7710          ENDIF
7711     1 CONTINUE
7712       ICRJSS = ICRJSS+1
7713       RETURN
7714
7715  9999 CONTINUE
7716       IREJ = 1
7717       RETURN
7718       END
7719
7720 *$ CREATE DT_VV2SCH.FOR
7721 *COPY DT_VV2SCH
7722 *
7723 *===vv2sch=============================================================*
7724 *
7725       SUBROUTINE DT_VV2SCH
7726
7727 ************************************************************************
7728 * Change Valence-Valence chain systems to Single CHain systems for     *
7729 * hadron-nucleus collisions with meson or antibaryon projectile.       *
7730 * (Reggeon contribution)                                               *
7731 * The single chain system is approximately treated as one chain and a  *
7732 * meson at rest.                                                       *
7733 * This version dated 18.01.95 is written by S. Roesler                 *
7734 ************************************************************************
7735
7736       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7737       SAVE
7738
7739       PARAMETER ( LINP = 10 ,
7740      &            LOUT = 6 ,
7741      &            LDAT = 9 )
7742
7743       PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7744
7745       LOGICAL LSTART
7746
7747 * event history
7748
7749       PARAMETER (NMXHKK=200000)
7750
7751       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7752      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7753      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7754
7755 * extended event history
7756       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7757      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7758      &                IHIST(2,NMXHKK)
7759
7760 * flags for input different options
7761       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7762       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7763      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7764
7765 * statistics
7766       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7767      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7768      &                ICEVTG(8,0:30)
7769
7770       DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7771      &          PCH2(4)
7772
7773       DATA LSTART /.TRUE./
7774
7775       IFSC  = 0
7776       IF (LSTART) THEN
7777          WRITE(LOUT,1000)
7778  1000    FORMAT(/,1X,'VV2SCH:  Reggeon contribution to valance-',
7779      &          'valence chains treated')
7780          LSTART = .FALSE.
7781       ENDIF
7782
7783       NSTOP = NHKK
7784
7785 * get index of first chain
7786       DO 1 I=NPOINT(3),NHKK
7787          IF (IDHKK(I).EQ.88888) THEN
7788             NC = I
7789             GOTO 2
7790          ENDIF
7791     1 CONTINUE
7792
7793     2 CONTINUE
7794       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7795      &                        .AND.(NC.LT.NSTOP)) THEN
7796 * get valence-valence chains
7797          IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7798 *   get "mother"-hadron indices
7799             MO1   = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7800             MO2   = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7801             KPROJ = IDT_ICIHAD(IDHKK(MO1))
7802             KTARG = IDT_ICIHAD(IDHKK(MO2))
7803 *   Lab momentum of projectile hadron
7804             CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7805             PTOT  = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7806      &                                  PHKK(3,MO1)**2)
7807
7808             SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7809             IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7810                ICVV2S = ICVV2S+1
7811 *   single chain requested
7812 *      get flavors of chain-end partons
7813                MO(1) = JMOHKK(1,NC)
7814                MO(2) = JMOHKK(2,NC)
7815                MO(3) = JMOHKK(1,NC+3)
7816                MO(4) = JMOHKK(2,NC+3)
7817                DO 3 I=1,4
7818                   IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7819                   IF(I,2) = 0
7820                   IF (ABS(IDHKK(MO(I))).GE.1000)
7821      &               IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7822     3          CONTINUE
7823 *      which one is the q-aq chain?
7824 *        N1,N1+1 - DTEVT1-entries for q-aq system
7825 *        N2,N2+1 - DTEVT1-entries for the other chain
7826                IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7827                   K1 = 1
7828                   K2 = 3
7829                   N1 = NC-2
7830                   N2 = NC+1
7831                ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7832                   K1 = 3
7833                   K2 = 1
7834                   N1 = NC+1
7835                   N2 = NC-2
7836                ELSE
7837                   GOTO 10
7838                ENDIF
7839                DO 4 K=1,4
7840                   PP1(K) = PHKK(K,N1)
7841                   PT1(K) = PHKK(K,N1+1)
7842                   PP2(K) = PHKK(K,N2)
7843                   PT2(K) = PHKK(K,N2+1)
7844     4          CONTINUE
7845                AMCH1 = PHKK(5,N1+2)
7846                AMCH2 = PHKK(5,N2+2)
7847 *      get meson-identity corresponding to flavors of q-aq chain
7848                ITMP   = IRESRJ
7849                IRESRJ = 0
7850                CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7851      &                     ZERO,AMCH1N,1,IDUM)
7852                IRESRJ = ITMP
7853 *      change kinematics of chains
7854                CALL DT_CHKINE(PP1,IDHKK(N1),  PP2,IDHKK(N2),
7855      &                     PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7856      &                     AMCH1,AMCH1N,AMCH2,IREJ1)
7857                IF (IREJ1.NE.0) GOTO 10
7858 *      check second chain for resonance
7859                IDCHAI = 2
7860                IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7861                CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7862      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7863                IF (IREJ1.NE.0) GOTO 10
7864                IF (IDR2.NE.0) IDR2 = 100*IDR2
7865 *      add partons and chains to DTEVT1
7866                DO 5 K=1,4
7867                   PCH1(K) = PP1(K)+PT1(K)
7868                   PCH2(K) = PP2(K)+PT2(K)
7869     5          CONTINUE
7870                CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7871      &                                             PP1(3),PP1(4),0,0,0)
7872                CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7873      &                                      PT1(2),PT1(3),PT1(4),0,0,0)
7874                KCH = ISTHKK(N1+2)+100
7875                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7876      &                     PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7877                IDHKK(N1+2) = 22222
7878                CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7879      &                                             PP2(3),PP2(4),0,0,0)
7880                CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7881      &                                      PT2(2),PT2(3),PT2(4),0,0,0)
7882                KCH = ISTHKK(N2+2)+100
7883                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7884      &                     PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7885                IDHKK(N2+2) = 22222
7886             ENDIF
7887          ENDIF
7888       ELSE
7889          GOTO 11
7890       ENDIF
7891    10 CONTINUE
7892       NC = NC+6
7893       GOTO 2
7894
7895    11 CONTINUE
7896
7897       RETURN
7898       END
7899
7900 *$ CREATE DT_PHNSCH.FOR
7901 *COPY DT_PHNSCH
7902 *
7903 *=== phnsch ===========================================================*
7904 *
7905       DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7906
7907 *----------------------------------------------------------------------*
7908 *                                                                      *
7909 *     Probability for Hadron Nucleon Single CHain interactions:        *
7910 *                                                                      *
7911 *     Created on 30 december 1993  by    Alfredo Ferrari & Paola Sala  *
7912 *                                                   Infn - Milan       *
7913 *                                                                      *
7914 *     Last change on 04-jan-94     by    Alfredo Ferrari               *
7915 *                                                                      *
7916 *             modified by J.R.for use in DTUNUC  6.1.94                *
7917 *                                                                      *
7918 *     Input variables:                                                 *
7919 *                      Kp = hadron projectile index (Part numbering    *
7920 *                           scheme)                                    *
7921 *                   Ktarg = target nucleon index (1=proton, 8=neutron) *
7922 *                    Plab = projectile laboratory momentum (GeV/c)     *
7923 *     Output variable:                                                 *
7924 *                  Phnsch = probability per single chain (particle     *
7925 *                           exchange) interactions                     *
7926 *                                                                      *
7927 *----------------------------------------------------------------------*
7928
7929       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7930       SAVE
7931
7932       PARAMETER ( LUNOUT = 6  )
7933       PARAMETER ( LUNERR = 6  )
7934       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
7935       PARAMETER ( ZERZER = 0.D+00 )
7936       PARAMETER ( ONEONE = 1.D+00 )
7937       PARAMETER ( TWOTWO = 2.D+00 )
7938       PARAMETER ( FIVFIV = 5.D+00 )
7939       PARAMETER ( HLFHLF = 0.5D+00 )
7940
7941       PARAMETER ( NALLWP = 39   )
7942       PARAMETER ( IDMAXP = 210  )
7943
7944       DIMENSION ICHRGE(39),AM(39)
7945
7946 * particle properties (BAMJET index convention)
7947       CHARACTER*8  ANAME
7948       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7949      &                IICH(210),IIBAR(210),K1(210),K2(210)
7950
7951       DIMENSION KPTOIP(210)
7952
7953 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7954       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7955      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7956      &                IQTCHR(-6:6),MQUARK(3,39)
7957
7958       DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7959       DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7960       EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7961       EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7962       EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7963
7964 * Conversion from part to paprop numbering
7965       DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7966      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7967      & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7968
7969 *  1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7970       DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7971      &    2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7972 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7973       DATA  SGTCO1  /
7974 * 1st reaction: gamma p total
7975      &0.147 D+00, ZERZER  , ZERZER   , 0.0022D+00, -0.0170D+00,
7976 * 2nd reaction: gamma d total
7977      &0.300 D+00, ZERZER  , ZERZER   , 0.0095D+00, -0.057 D+00,
7978 * 3rd reaction: pi+ p total
7979      &16.4  D+00, 19.3D+00, -0.42D+00, 0.19  D+00, ZERZER     ,
7980 * 4th reaction: pi- p total
7981      &33.0  D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03  D+00,
7982 * 5th reaction: pi+/- d total
7983      &56.8  D+00, 42.2D+00, -1.45D+00, 0.65  D+00, -5.39  D+00,
7984 * 6th reaction: K+ p total
7985      &18.1  D+00, ZERZER  , ZERZER   , 0.26  D+00, -1.0   D+00,
7986 * 7th reaction: K+ n total
7987      &18.7  D+00, ZERZER  , ZERZER   , 0.21  D+00, -0.89  D+00,
7988 * 8th reaction: K+ d total
7989      &34.2  D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99  D+00,
7990 * 9th reaction: K- p total
7991      &32.1  D+00, ZERZER  , ZERZER   , 0.66  D+00, -5.6   D+00,
7992 * 10th reaction: K- n total
7993      &25.2  D+00, ZERZER  , ZERZER   , 0.38  D+00, -2.9   D+00/
7994 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7995       DATA  SGTCO2  /
7996 * 11th reaction: K- d total
7997      &57.6  D+00, ZERZER  , ZERZER   , 1.17  D+00, -9.5   D+00,
7998 * 12th reaction: p p total
7999      &48.0  D+00, ZERZER  , ZERZER   , 0.522 D+00, -4.51  D+00,
8000 * 13th reaction: p n total
8001      &47.30 D+00, ZERZER  , ZERZER   , 0.513 D+00, -4.27  D+00,
8002 * 14th reaction: p d total
8003      &91.3  D+00, ZERZER  , ZERZER   , 1.05  D+00, -8.8   D+00,
8004 * 15th reaction: pbar p total
8005      &38.4  D+00, 77.6D+00, -0.64D+00, 0.26  D+00, -1.2   D+00,
8006 * 16th reaction: pbar n total
8007      &ZERZER    ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7   D+00,
8008 * 17th reaction: pbar d total
8009      &112.  D+00, 125.D+00, -1.08D+00, 1.14  D+00, -12.4  D+00,
8010 * 18th reaction: Lamda p total
8011      &30.4  D+00, ZERZER  , ZERZER   , ZERZER    , 1.6    D+00/
8012 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
8013       DATA SGTCO3  /
8014 * 19th reaction: pi+ p elastic
8015      &ZERZER    , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER     ,
8016 * 20th reaction: pi- p elastic
8017      &1.76  D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER     ,
8018 * 21st reaction: K+ p elastic
8019      &5.0   D+00, 8.1 D+00, -1.8 D+00, 0.16  D+00, -1.3   D+00,
8020 * 22nd reaction: K- p elastic
8021      &7.3   D+00, ZERZER  , ZERZER   , 0.29  D+00, -2.40  D+00,
8022 * 23rd reaction: p p elastic
8023      &11.9  D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85  D+00,
8024 * 24th reaction: p d elastic
8025      &16.1  D+00, ZERZER  , ZERZER   , 0.32  D+00, -3.4   D+00,
8026 * 25th reaction: pbar p elastic
8027      &10.2  D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28  D+00,
8028 * 26th reaction: pbar p elastic bis
8029      &10.6  D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41  D+00,
8030 * 27th reaction: pbar n elastic
8031      &36.5  D+00, ZERZER  , ZERZER   , ZERZER    , -11.9  D+00,
8032 * 28th reaction: Lamda p elastic
8033      &12.3  D+00, ZERZER  , ZERZER   , ZERZER    , -2.4   D+00,
8034 * 29th reaction: K- p ela bis
8035      &7.24  D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35  D+00,
8036 * 30th reaction: pi- p cx
8037      &ZERZER    ,0.912D+00, -1.22D+00, ZERZER    , ZERZER     ,
8038 * 31st reaction: K- p cx
8039      &ZERZER    , 3.39D+00, -1.75D+00, ZERZER    , ZERZER     ,
8040 * 32nd reaction: K+ n cx
8041      &ZERZER    , 7.18D+00, -2.01D+00, ZERZER    , ZERZER     ,
8042 * 33rd reaction: pbar p cx
8043      &ZERZER    , 18.8D+00, -2.01D+00, ZERZER    , ZERZER     /
8044 *
8045 *  +-------------------------------------------------------------------*
8046          ICHRGE(KTARG)=IICH(KTARG)
8047          AM    (KTARG)=AAM (KTARG)
8048 *  |  Check for pi0 (d-dbar)
8049       IF ( KP .NE. 26 ) THEN
8050          IP  = KPTOIP (KP)
8051          IF(IP.EQ.0)IP=1
8052          ICHRGE(IP)=IICH(KP)
8053          AM    (IP)=AAM (KP)
8054 *  |
8055 *  +-------------------------------------------------------------------*
8056 *  |
8057       ELSE
8058          IP = 23
8059          ICHRGE(IP)=0
8060       END IF
8061 *  |
8062 *  +-------------------------------------------------------------------*
8063 *  +-------------------------------------------------------------------*
8064 *  |  No such interactions for baryon-baryon
8065       IF ( IIBAR (KP) .GT. 0 ) THEN
8066          DT_PHNSCH = ZERZER
8067          RETURN
8068 *  |
8069 *  +-------------------------------------------------------------------*
8070 *  |  No "annihilation" diagram possible for K+ p/n
8071       ELSE IF ( IP .EQ. 15 ) THEN
8072          DT_PHNSCH = ZERZER
8073          RETURN
8074 *  |
8075 *  +-------------------------------------------------------------------*
8076 *  |  No "annihilation" diagram possible for K0 p/n
8077       ELSE IF ( IP .EQ. 24 ) THEN
8078          DT_PHNSCH = ZERZER
8079          RETURN
8080 *  |
8081 *  +-------------------------------------------------------------------*
8082 *  |  No "annihilation" diagram possible for Omebar p/n
8083       ELSE IF ( IP .GE. 38 ) THEN
8084          DT_PHNSCH = ZERZER
8085          RETURN
8086       END IF
8087 *  |
8088 *  +-------------------------------------------------------------------*
8089 *  +-------------------------------------------------------------------*
8090 *  |  If the momentum is larger than 50 GeV/c, compute the single
8091 *  |  chain probability at 50 GeV/c and extrapolate to the present
8092 *  |  momentum according to 1/sqrt(s)
8093 *  |  sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
8094 *  |  P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
8095 *  |  sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
8096 *  |  sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
8097 *  |                        x sqrt(s/s(50))
8098 *  |  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8099       IF ( PLAB .GT. 50.D+00 ) THEN
8100          PLA    = 50.D+00
8101          AMPSQ  = AM (IP)**2
8102          AMTSQ  = AM (KTARG)**2
8103          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
8104          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8105          EPROJ  = SQRT ( PLA**2 + AMPSQ )
8106          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8107          UMORAT = SQRT ( UMOSQ / UMO50 )
8108 *  |
8109 *  +-------------------------------------------------------------------*
8110 *  |  P < 3 GeV/c
8111       ELSE IF ( PLAB .LT. 3.D+00 ) THEN
8112          PLA    = 3.D+00
8113          AMPSQ  = AM (IP)**2
8114          AMTSQ  = AM (KTARG)**2
8115          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
8116          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8117          EPROJ  = SQRT ( PLA**2 + AMPSQ )
8118          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8119          UMORAT = SQRT ( UMOSQ / UMO50 )
8120 *  |
8121 *  +-------------------------------------------------------------------*
8122 *  |  P < 50 GeV/c
8123       ELSE
8124          PLA    = PLAB
8125          UMORAT = ONEONE
8126       END IF
8127 *  |
8128 *  +-------------------------------------------------------------------*
8129       ALGPLA = LOG (PLA)
8130 *  +-------------------------------------------------------------------*
8131 *  |  Pions:
8132       IF ( IHLP (IP) .EQ. 2 ) THEN
8133          ACOF = SGTCOE (1,3)
8134          BCOF = SGTCOE (2,3)
8135          ENNE = SGTCOE (3,3)
8136          CCOF = SGTCOE (4,3)
8137          DCOF = SGTCOE (5,3)
8138 *  |  Compute the pi+ p total cross section:
8139          SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8140      &          + DCOF * ALGPLA
8141          ACOF = SGTCOE (1,19)
8142          BCOF = SGTCOE (2,19)
8143          ENNE = SGTCOE (3,19)
8144          CCOF = SGTCOE (4,19)
8145          DCOF = SGTCOE (5,19)
8146 *  |  Compute the pi+ p elastic cross section:
8147          SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8148      &          + DCOF * ALGPLA
8149 *  |  Compute the pi+ p inelastic cross section:
8150          SPPPIN = SPPPTT - SPPPEL
8151          ACOF = SGTCOE (1,4)
8152          BCOF = SGTCOE (2,4)
8153          ENNE = SGTCOE (3,4)
8154          CCOF = SGTCOE (4,4)
8155          DCOF = SGTCOE (5,4)
8156 *  |  Compute the pi- p total cross section:
8157          SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8158      &          + DCOF * ALGPLA
8159          ACOF = SGTCOE (1,20)
8160          BCOF = SGTCOE (2,20)
8161          ENNE = SGTCOE (3,20)
8162          CCOF = SGTCOE (4,20)
8163          DCOF = SGTCOE (5,20)
8164 *  |  Compute the pi- p elastic cross section:
8165          SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8166      &          + DCOF * ALGPLA
8167 *  |  Compute the pi- p inelastic cross section:
8168          SPMPIN = SPMPTT - SPMPEL
8169          SIGDIA = SPMPIN - SPPPIN
8170 *  |  +----------------------------------------------------------------*
8171 *  |  |  Charged pions: besides isospin consideration it is supposed
8172 *  |  |                 that (pi+ n)el is almost equal to (pi- p)el
8173 *  |  |                 and  (pi+ p)el "    "     "    "  (pi- n)el
8174 *  |  |                 and all are almost equal among each others
8175 *  |  |                 (reasonable above 5 GeV/c)
8176          IF ( ICHRGE (IP) .NE. 0 ) THEN
8177             KHELP = KTARG / 8
8178             JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
8179             ACOF = SGTCOE (1,JREAC)
8180             BCOF = SGTCOE (2,JREAC)
8181             ENNE = SGTCOE (3,JREAC)
8182             CCOF = SGTCOE (4,JREAC)
8183             DCOF = SGTCOE (5,JREAC)
8184 *  |  |  Compute the total cross section:
8185             SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8186      &             + DCOF * ALGPLA
8187             JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
8188             ACOF = SGTCOE (1,JREAC)
8189             BCOF = SGTCOE (2,JREAC)
8190             ENNE = SGTCOE (3,JREAC)
8191             CCOF = SGTCOE (4,JREAC)
8192             DCOF = SGTCOE (5,JREAC)
8193 *  |  |  Compute the elastic cross section:
8194             SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8195      &             + DCOF * ALGPLA
8196 *  |  |  Compute the inelastic cross section:
8197             SHNCIN = SHNCTT - SHNCEL
8198 *  |  |  Number of diagrams:
8199             NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
8200 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8201             IQFSC1 = 1 + IP - 13
8202             IQFSC2 = 0
8203             IQBSC1 = 1 + KHELP
8204             IQBSC2 = 1 + IP - 13
8205 *  |  |
8206 *  |  +----------------------------------------------------------------*
8207 *  |  |  pi0: besides isospin consideration it is supposed that the
8208 *  |  |       elastic cross section is not very different from
8209 *  |  |       pi+ p and/or pi- p (reasonable above 5 GeV/c)
8210          ELSE
8211             KHELP  = KTARG / 8
8212             K2HLP  = ( KP - 23 ) / 3
8213 *  |  |  Number of diagrams:
8214 *  |  |  For u ubar (k2hlp=0):
8215 *           NDIAGR = 2 - KHELP
8216 *  |  |  For d dbar (k2hlp=1):
8217 *           NDIAGR = 2 + KHELP - K2HLP
8218             NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
8219             SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
8220 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8221             IQFSC1 = 1 + K2HLP
8222             IQFSC2 = 0
8223             IQBSC1 = 1 + KHELP
8224             IQBSC2 = 2 - K2HLP
8225          END IF
8226 *  |  |
8227 *  |  +----------------------------------------------------------------*
8228 *  |                                                   end pi's
8229 *  +-------------------------------------------------------------------*
8230 *  |  Kaons:
8231       ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
8232          ACOF = SGTCOE (1,6)
8233          BCOF = SGTCOE (2,6)
8234          ENNE = SGTCOE (3,6)
8235          CCOF = SGTCOE (4,6)
8236          DCOF = SGTCOE (5,6)
8237 *  |  Compute the K+ p total cross section:
8238          SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8239      &          + DCOF * ALGPLA
8240          ACOF = SGTCOE (1,21)
8241          BCOF = SGTCOE (2,21)
8242          ENNE = SGTCOE (3,21)
8243          CCOF = SGTCOE (4,21)
8244          DCOF = SGTCOE (5,21)
8245 *  |  Compute the K+ p elastic cross section:
8246          SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8247      &          + DCOF * ALGPLA
8248 *  |  Compute the K+ p inelastic cross section:
8249          SKPPIN = SKPPTT - SKPPEL
8250          ACOF = SGTCOE (1,9)
8251          BCOF = SGTCOE (2,9)
8252          ENNE = SGTCOE (3,9)
8253          CCOF = SGTCOE (4,9)
8254          DCOF = SGTCOE (5,9)
8255 *  |  Compute the K- p total cross section:
8256          SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8257      &          + DCOF * ALGPLA
8258          ACOF = SGTCOE (1,22)
8259          BCOF = SGTCOE (2,22)
8260          ENNE = SGTCOE (3,22)
8261          CCOF = SGTCOE (4,22)
8262          DCOF = SGTCOE (5,22)
8263 *  |  Compute the K- p elastic cross section:
8264          SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8265      &          + DCOF * ALGPLA
8266 *  |  Compute the K- p inelastic cross section:
8267          SKMPIN = SKMPTT - SKMPEL
8268          SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
8269 *  |  +----------------------------------------------------------------*
8270 *  |  |  Charged Kaons: actually only K-
8271          IF ( ICHRGE (IP) .NE. 0 ) THEN
8272             KHELP = KTARG / 8
8273 *  |  |  +-------------------------------------------------------------*
8274 *  |  |  |  Proton target:
8275             IF ( KHELP .EQ. 0 ) THEN
8276                SHNCIN = SKMPIN
8277 *  |  |  |  Number of diagrams:
8278                NDIAGR = 2
8279 *  |  |  |
8280 *  |  |  +-------------------------------------------------------------*
8281 *  |  |  |  Neutron target: besides isospin consideration it is supposed
8282 *  |  |  |              that (K- n)el is almost equal to (K- p)el
8283 *  |  |  |              (reasonable above 5 GeV/c)
8284             ELSE
8285                ACOF = SGTCOE (1,10)
8286                BCOF = SGTCOE (2,10)
8287                ENNE = SGTCOE (3,10)
8288                CCOF = SGTCOE (4,10)
8289                DCOF = SGTCOE (5,10)
8290 *  |  |  |  Compute the total cross section:
8291                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8292      &                + DCOF * ALGPLA
8293 *  |  |  |  Compute the elastic cross section:
8294                SHNCEL = SKMPEL
8295 *  |  |  |  Compute the inelastic cross section:
8296                SHNCIN = SHNCTT - SHNCEL
8297 *  |  |  |  Number of diagrams:
8298                NDIAGR = 1
8299             END IF
8300 *  |  |  |
8301 *  |  |  +-------------------------------------------------------------*
8302 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8303             IQFSC1 = 3
8304             IQFSC2 = 0
8305             IQBSC1 = 1 + KHELP
8306             IQBSC2 = 2
8307 *  |  |
8308 *  |  +----------------------------------------------------------------*
8309 *  |  |  K0's: (actually only K0bar)
8310          ELSE
8311             KHELP  = KTARG / 8
8312 *  |  |  +-------------------------------------------------------------*
8313 *  |  |  |  Proton target: (K0bar p)in supposed to be given by
8314 *  |  |  |                 (K- p)in - Sig_diagr
8315             IF ( KHELP .EQ. 0 ) THEN
8316                SHNCIN = SKMPIN - SIGDIA
8317 *  |  |  |  Number of diagrams:
8318                NDIAGR = 1
8319 *  |  |  |
8320 *  |  |  +-------------------------------------------------------------*
8321 *  |  |  |  Neutron target: (K0bar n)in supposed to be given by
8322 *  |  |  |                 (K- n)in + Sig_diagr
8323 *  |  |  |              besides isospin consideration it is supposed
8324 *  |  |  |              that (K- n)el is almost equal to (K- p)el
8325 *  |  |  |              (reasonable above 5 GeV/c)
8326             ELSE
8327                ACOF = SGTCOE (1,10)
8328                BCOF = SGTCOE (2,10)
8329                ENNE = SGTCOE (3,10)
8330                CCOF = SGTCOE (4,10)
8331                DCOF = SGTCOE (5,10)
8332 *  |  |  |  Compute the total cross section:
8333                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8334      &                + DCOF * ALGPLA
8335 *  |  |  |  Compute the elastic cross section:
8336                SHNCEL = SKMPEL
8337 *  |  |  |  Compute the inelastic cross section:
8338                SHNCIN = SHNCTT - SHNCEL + SIGDIA
8339 *  |  |  |  Number of diagrams:
8340                NDIAGR = 2
8341             END IF
8342 *  |  |  |
8343 *  |  |  +-------------------------------------------------------------*
8344 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8345             IQFSC1 = 3
8346             IQFSC2 = 0
8347             IQBSC1 = 1
8348             IQBSC2 = 1 + KHELP
8349          END IF
8350 *  |  |
8351 *  |  +----------------------------------------------------------------*
8352 *  |                                                   end Kaon's
8353 *  +-------------------------------------------------------------------*
8354 *  |  Antinucleons:
8355       ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
8356 *  |  For momenta between 3 and 5 GeV/c the use of tabulated data
8357 *  |  should be implemented!
8358          ACOF = SGTCOE (1,15)
8359          BCOF = SGTCOE (2,15)
8360          ENNE = SGTCOE (3,15)
8361          CCOF = SGTCOE (4,15)
8362          DCOF = SGTCOE (5,15)
8363 *  |  Compute the pbar p total cross section:
8364          SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8365      &          + DCOF * ALGPLA
8366          IF ( PLA .LT. FIVFIV ) THEN
8367             JREAC = 26
8368          ELSE
8369             JREAC = 25
8370          END IF
8371          ACOF = SGTCOE (1,JREAC)
8372          BCOF = SGTCOE (2,JREAC)
8373          ENNE = SGTCOE (3,JREAC)
8374          CCOF = SGTCOE (4,JREAC)
8375          DCOF = SGTCOE (5,JREAC)
8376 *  |  Compute the pbar p elastic cross section:
8377          SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8378      &          + DCOF * ALGPLA
8379 *  |  Compute the pbar p inelastic cross section:
8380          SAPPIN = SAPPTT - SAPPEL
8381          ACOF = SGTCOE (1,12)
8382          BCOF = SGTCOE (2,12)
8383          ENNE = SGTCOE (3,12)
8384          CCOF = SGTCOE (4,12)
8385          DCOF = SGTCOE (5,12)
8386 *  |  Compute the p p total cross section:
8387          SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8388      &          + DCOF * ALGPLA
8389          ACOF = SGTCOE (1,23)
8390          BCOF = SGTCOE (2,23)
8391          ENNE = SGTCOE (3,23)
8392          CCOF = SGTCOE (4,23)
8393          DCOF = SGTCOE (5,23)
8394 *  |  Compute the p p elastic cross section:
8395          SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8396      &          + DCOF * ALGPLA
8397 *  |  Compute the K- p inelastic cross section:
8398          SPPINE = SPPTOT - SPPELA
8399          SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
8400          KHELP  = KTARG / 8
8401 *  |  +----------------------------------------------------------------*
8402 *  |  |  Pbar:
8403          IF ( ICHRGE (IP) .NE. 0 ) THEN
8404             NDIAGR = 5 - KHELP
8405 *  |  |  +-------------------------------------------------------------*
8406 *  |  |  |  Proton target:
8407             IF ( KHELP .EQ. 0 ) THEN
8408 *  |  |  |  Number of diagrams:
8409                SHNCIN = SAPPIN
8410                PUUBAR = 0.8D+00
8411 *  |  |  |
8412 *  |  |  +-------------------------------------------------------------*
8413 *  |  |  |  Neutron target: it is supposed that (ap n)el is almost equal
8414 *  |  |  |                  to (ap p)el (reasonable above 5 GeV/c)
8415             ELSE
8416                ACOF = SGTCOE (1,16)
8417                BCOF = SGTCOE (2,16)
8418                ENNE = SGTCOE (3,16)
8419                CCOF = SGTCOE (4,16)
8420                DCOF = SGTCOE (5,16)
8421 *  |  |  |  Compute the total cross section:
8422                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8423      &                + DCOF * ALGPLA
8424 *  |  |  |  Compute the elastic cross section:
8425                SHNCEL = SAPPEL
8426 *  |  |  |  Compute the inelastic cross section:
8427                SHNCIN = SHNCTT - SHNCEL
8428                PUUBAR = HLFHLF
8429             END IF
8430 *  |  |  |
8431 *  |  |  +-------------------------------------------------------------*
8432 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8433 *  |  |  there are different possibilities, make a random choiche:
8434             IQFSC1 = -1
8435             RNCHEN = DT_RNDM(PUUBAR)
8436             IF ( RNCHEN .LT. PUUBAR ) THEN
8437                IQFSC2 = -2
8438             ELSE
8439                IQFSC2 = -1
8440             END IF
8441             IQBSC1 = -IQFSC1 + KHELP
8442             IQBSC2 = -IQFSC2
8443 *  |  |
8444 *  |  +----------------------------------------------------------------*
8445 *  |  |  nbar:
8446          ELSE
8447             NDIAGR = 4 + KHELP
8448 *  |  |  +-------------------------------------------------------------*
8449 *  |  |  |  Proton target: (nbar p)in supposed to be given by
8450 *  |  |  |                 (pbar p)in - Sig_diagr
8451             IF ( KHELP .EQ. 0 ) THEN
8452                SHNCIN = SAPPIN - SIGDIA
8453                PDDBAR = HLFHLF
8454 *  |  |  |
8455 *  |  |  +-------------------------------------------------------------*
8456 *  |  |  |  Neutron target: (nbar n)el is supposed to be equal to
8457 *  |  |  |                  (pbar p)el (reasonable above 5 GeV/c)
8458             ELSE
8459 *  |  |  |  Compute the total cross section:
8460                SHNCTT = SAPPTT
8461 *  |  |  |  Compute the elastic cross section:
8462                SHNCEL = SAPPEL
8463 *  |  |  |  Compute the inelastic cross section:
8464                SHNCIN = SHNCTT - SHNCEL
8465                PDDBAR = 0.8D+00
8466             END IF
8467 *  |  |  |
8468 *  |  |  +-------------------------------------------------------------*
8469 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8470 *  |  |  there are different possibilities, make a random choiche:
8471             IQFSC1 = -2
8472             RNCHEN = DT_RNDM(RNCHEN)
8473             IF ( RNCHEN .LT. PDDBAR ) THEN
8474                IQFSC2 = -1
8475             ELSE
8476                IQFSC2 = -2
8477             END IF
8478             IQBSC1 = -IQFSC1 + KHELP - 1
8479             IQBSC2 = -IQFSC2
8480          END IF
8481 *  |  |
8482 *  |  +----------------------------------------------------------------*
8483 *  |
8484 *  +-------------------------------------------------------------------*
8485 *  |  Others: not yet implemented
8486       ELSE
8487          SIGDIA = ZERZER
8488          SHNCIN = ONEONE
8489          NDIAGR = 0
8490          DT_PHNSCH = ZERZER
8491          RETURN
8492       END IF
8493 *  |                                                   end others
8494 *  +-------------------------------------------------------------------*
8495       DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8496       IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8497      &       + IQECHR (IQBSC2)
8498       IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8499      &       + IQBCHR (IQBSC2)
8500       IQECHC = IQECHC / 3
8501       IQBCHC = IQBCHC / 3
8502       IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8503      &       + IQSCHR (IQBSC2)
8504       IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8505      &       + IQSCHR (MQUARK(3,IP))
8506 *  +-------------------------------------------------------------------*
8507 *  |  Consistency check:
8508       IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8509          WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8510      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8511          WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8512      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8513          DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8514          DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8515       END IF
8516 *  |
8517 *  +-------------------------------------------------------------------*
8518 *  +-------------------------------------------------------------------*
8519 *  |  Consistency check:
8520       IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8521      &     .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8522          WRITE (LUNOUT,*)
8523      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8524      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8525          WRITE (LUNERR,*)
8526      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8527      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8528       END IF
8529 *  |
8530 *  +-------------------------------------------------------------------*
8531 *  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8532       IF ( UMORAT .GT. ONEPLS )
8533      &   DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8534      &                                 - ONEONE ) * UMORAT + ONEONE )
8535       RETURN
8536 *
8537       ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8538       DT_SCHQUA = ONEONE
8539       JQFSC1 = IQFSC1
8540       JQFSC2 = IQFSC2
8541       JQBSC1 = IQBSC1
8542       JQBSC2 = IQBSC2
8543 *=== End of function Phnsch ===========================================*
8544       RETURN
8545       END
8546
8547 *$ CREATE DT_RESPT.FOR
8548 *COPY DT_RESPT
8549 *
8550 *===respt==============================================================*
8551 *
8552       SUBROUTINE DT_RESPT
8553
8554 ************************************************************************
8555 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t.     *
8556 * This version dated 18.01.95 is written by S. Roesler                 *
8557 ************************************************************************
8558
8559       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8560       SAVE
8561
8562       PARAMETER ( LINP = 10 ,
8563      &            LOUT = 6 ,
8564      &            LDAT = 9 )
8565
8566       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8567
8568 * event history
8569
8570       PARAMETER (NMXHKK=200000)
8571
8572       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8573      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8574      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8575
8576 * extended event history
8577       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8578      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8579      &                IHIST(2,NMXHKK)
8580
8581 * get index of first chain
8582       DO 1 I=NPOINT(3),NHKK
8583          IF (IDHKK(I).EQ.88888) THEN
8584             NC = I
8585             GOTO 2
8586          ENDIF
8587     1 CONTINUE
8588
8589     2 CONTINUE
8590       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8591 C        WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8592 * skip VV-,SS- systems
8593          IF ((IDCH(NC  ).NE.1).AND.(IDCH(NC  ).NE.8).AND.
8594      &       (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8595 * check if both "chains" are resonances
8596             IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8597                CALL DT_SAPTRE(NC,NC+3)
8598             ENDIF
8599          ENDIF
8600       ELSE
8601          GOTO 3
8602       ENDIF
8603       NC = NC+6
8604       GOTO 2
8605
8606     3 CONTINUE
8607
8608       RETURN
8609       END
8610
8611 *$ CREATE DT_EVTRES.FOR
8612 *COPY DT_EVTRES
8613 *
8614 *===evtres=============================================================*
8615 *
8616       SUBROUTINE DT_EVTRES(IREJ)
8617
8618 ************************************************************************
8619 * This version dated 14.12.94 is written by S. Roesler                 *
8620 ************************************************************************
8621
8622       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8623       SAVE
8624
8625       PARAMETER ( LINP = 10 ,
8626      &            LOUT = 6 ,
8627      &            LDAT = 9 )
8628
8629       PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8630
8631 * event history
8632
8633       PARAMETER (NMXHKK=200000)
8634
8635       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8636      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8637      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8638
8639 * extended event history
8640       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8641      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8642      &                IHIST(2,NMXHKK)
8643
8644 * flags for input different options
8645       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8646       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8647      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8648
8649 * particle properties (BAMJET index convention)
8650       CHARACTER*8  ANAME
8651       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8652      &                IICH(210),IIBAR(210),K1(210),K2(210)
8653
8654       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8655
8656       IREJ = 0
8657
8658       DO 1 I=NPOINT(3),NHKK
8659          IF (ABS(IDRES(I)).GE.100) THEN
8660             AMMX = 0.0D0
8661             DO 2 J=NPOINT(3),NHKK
8662                IF (IDHKK(J).EQ.88888) THEN
8663                   IF (PHKK(5,J).GT.AMMX) THEN
8664                      AMMX = PHKK(5,J)
8665                      IMMX = J
8666                   ENDIF
8667                ENDIF
8668     2       CONTINUE
8669             IF (IDRES(IMMX).NE.0) THEN
8670                IF (IOULEV(3).GT.0) THEN
8671                   WRITE(LOUT,'(1X,A)')
8672      &               'EVTRES: no chain for correc. found'
8673 C                 GOTO 6
8674                   GOTO 9999
8675                ELSE
8676                   GOTO 9999
8677                ENDIF
8678             ENDIF
8679             IMO11  = JMOHKK(1,I)
8680             IMO12  = JMOHKK(2,I)
8681             IF (PHKK(3,IMO11).LT.0.0D0) THEN
8682                IMO11 = JMOHKK(2,I)
8683                IMO12 = JMOHKK(1,I)
8684             ENDIF
8685             IMO21  = JMOHKK(1,IMMX)
8686             IMO22  = JMOHKK(2,IMMX)
8687             IF (PHKK(3,IMO21).LT.0.0D0) THEN
8688                IMO21 = JMOHKK(2,IMMX)
8689                IMO22 = JMOHKK(1,IMMX)
8690             ENDIF
8691             AMCH1  = PHKK(5,I)
8692             AMCH1N = AAM(IDXRES(I))
8693
8694             IFPR1 = IDHKK(IMO11)
8695             IFPR2 = IDHKK(IMO21)
8696             IFTA1 = IDHKK(IMO12)
8697             IFTA2 = IDHKK(IMO22)
8698             DO 4 J=1,4
8699                PP1(J) = PHKK(J,IMO11)
8700                PP2(J) = PHKK(J,IMO21)
8701                PT1(J) = PHKK(J,IMO12)
8702                PT2(J) = PHKK(J,IMO22)
8703     4       CONTINUE
8704 * store initial configuration for energy-momentum cons. check
8705             IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8706 * correct kinematics of second chain
8707             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8708      &                  AMCH1,AMCH1N,AMCH2,IREJ1)
8709             IF (IREJ1.NE.0) GOTO 9999
8710 * check now this chain for resonance mass
8711             IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8712             IFP(2) = 0
8713             IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8714             IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8715             IFT(2) = 0
8716             IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8717             IDCH2 = 2
8718             IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8719             IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8720             CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8721      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
8722             IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8723                IF (IOULEV(1).GT.0)
8724      &            WRITE(LOUT,*) ' correction for resonance not poss.'
8725 **sr test
8726 C              GOTO 1
8727 C              GOTO 9999
8728 **
8729             ENDIF
8730 * store final configuration for energy-momentum cons. check
8731             IF (LEMCCK) THEN
8732                CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8733                CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8734                IF (IREJ1.NE.0) GOTO 9999
8735             ENDIF
8736             DO 5 J=1,4
8737                PHKK(J,IMO11) = PP1(J)
8738                PHKK(J,IMO21) = PP2(J)
8739                PHKK(J,IMO12) = PT1(J)
8740                PHKK(J,IMO22) = PT2(J)
8741     5       CONTINUE
8742 * correct entries of chains
8743             DO 3 K=1,4
8744                PHKK(K,I)    = PHKK(K,IMO11)+PHKK(K,IMO12)
8745                PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8746     3       CONTINUE
8747             AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8748             AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8749      &            PHKK(3,IMMX)**2
8750 * ?? the following should now be obsolete
8751 **sr test
8752 C           IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8753             IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8754 **
8755                WRITE(LOUT,'(1X,A,4G10.3)')
8756      &          'EVTRES: inonsistent mass-corr.',AM1,AM2
8757 C              GOTO 9999
8758                GOTO 1
8759             ENDIF
8760             PHKK(5,I)    = SQRT(AM1)
8761             PHKK(5,IMMX) = SQRT(AM2)
8762             IDRES(I)     = IDRES(I)/100
8763             IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8764      &          (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8765                WRITE(LOUT,'(1X,A,4G10.3)')
8766      &          'EVTRES: inconsistent chain-masses',
8767      &          PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8768                GOTO 9999
8769             ENDIF
8770          ENDIF
8771     1 CONTINUE
8772     6 CONTINUE
8773       RETURN
8774
8775  9999 CONTINUE
8776       IREJ = 1
8777       RETURN
8778       END
8779
8780 *$ CREATE DT_GETSPT.FOR
8781 *COPY DT_GETSPT
8782 *
8783 *===getspt=============================================================*
8784 *
8785       SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8786      &                  PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8787      &                  AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8788
8789 ************************************************************************
8790 * This version dated 12.12.94 is written by S. Roesler                 *
8791 ************************************************************************
8792
8793       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8794       SAVE
8795
8796       PARAMETER ( LINP = 10 ,
8797      &            LOUT = 6 ,
8798      &            LDAT = 9 )
8799
8800       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8801
8802 * various options for treatment of partons (DTUNUC 1.x)
8803 * (chain recombination, Cronin,..)
8804       LOGICAL LCO2CR,LINTPT
8805       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8806      &                LCO2CR,LINTPT
8807
8808 * flags for input different options
8809       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8810       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8811      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8812
8813 * flags for diffractive interactions (DTUNUC 1.x)
8814       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8815
8816       DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8817      &          PT2(4),PT2I(4),P1(4),P2(4),
8818      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8819      &          PTOTI(4),PTOTF(4),DIFF(4)
8820
8821       IC   = 0
8822       IREJ = 0
8823 C     B33P = 4.0D0
8824 C     B33T = 4.0D0
8825 C     IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8826 C     IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8827       REDU = 1.0D0
8828 C     B33P = 3.5D0
8829 C     B33T = 3.5D0
8830       B33P = 4.0D0
8831       B33T = 4.0D0
8832       IF (IDIFF.NE.0) THEN
8833          B33P = 16.0D0
8834          B33T = 16.0D0
8835       ENDIF
8836
8837       DO 1 I=1,4
8838          PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8839          PP1(I)   = PP1I(I)
8840          PP2(I)   = PP2I(I)
8841          PT1(I)   = PT1I(I)
8842          PT2(I)   = PT2I(I)
8843     1 CONTINUE
8844 * get initial chain masses
8845       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8846      &                               +(PP1(3)+PT1(3))**2)
8847       ECH   = PP1(4)+PT1(4)
8848       AM1   = (ECH+PTOCH)*(ECH-PTOCH)
8849       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8850      &                               +(PP2(3)+PT2(3))**2)
8851       ECH   = PP2(4)+PT2(4)
8852       AM2   = (ECH+PTOCH)*(ECH-PTOCH)
8853       IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8854          IF (IOULEV(1).GT.0)
8855      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8856      &                              AM1,AM2
8857          GOTO 9999
8858       ENDIF
8859       AM1  = SQRT(AM1)
8860       AM2  = SQRT(AM2)
8861       AM1N = ZERO
8862       AM2N = ZERO
8863
8864       MODE = 0
8865 C      IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8866 C        MODE = 0
8867 C      ELSE
8868 C         MODE = 1
8869 C         IF (AM1.LT.0.6) THEN
8870 C            B33P = 10.0D0
8871 C         ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8872 CC           B33P = 4.0D0
8873 C         ENDIF
8874 C         IF (AM2.LT.0.6) THEN
8875 C            B33T = 10.0D0
8876 C         ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8877 CC           B33T = 4.0D0
8878 C         ENDIF
8879 C      ENDIF
8880
8881 * check chain masses for very low mass chains
8882 C     CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8883 C    &            AM1,DUM,-IDCH1,IREJ1)
8884 C     CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8885 C    &            AM2,DUM,-IDCH2,IREJ2)
8886 C     IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8887 C        B33P = 20.0D0
8888 C        B33T = 20.0D0
8889 C     ENDIF
8890
8891       JMSHL = IMSHL
8892
8893     2 CONTINUE
8894       IC = IC+1
8895       IF (MOD(IC,15).EQ.0) B33P  = 2.0D0*B33P
8896       IF (MOD(IC,15).EQ.0) B33T  = 2.0D0*B33T
8897       IF (MOD(IC,18).EQ.0) REDU  = 0.0D0
8898 C     IF (MOD(IC,19).EQ.0) JMSHL = 0
8899       IF (MOD(IC,20).EQ.0) GOTO 7
8900 C        WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8901 C        RETURN
8902 C        GOTO 9999
8903 C     ENDIF
8904
8905 * get transverse momentum
8906       IF (LINTPT) THEN
8907          ES   = -2.0D0/(B33P**2)
8908      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8909          HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8910          HPSP = HPSP*REDU
8911          ES   = -2.0D0/(B33T**2)
8912      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8913          HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8914          HPST = HPST*REDU
8915       ELSE
8916          HPSP = ZERO
8917          HPST = ZERO
8918       ENDIF
8919       CALL DT_DSFECF(SFE1,CFE1)
8920       CALL DT_DSFECF(SFE2,CFE2)
8921       IF (MODE.EQ.0) THEN
8922          PP1(1) = PP1I(1)+HPSP*CFE1
8923          PP1(2) = PP1I(2)+HPSP*SFE1
8924          PP2(1) = PP2I(1)-HPSP*CFE1
8925          PP2(2) = PP2I(2)-HPSP*SFE1
8926          PT1(1) = PT1I(1)+HPST*CFE2
8927          PT1(2) = PT1I(2)+HPST*SFE2
8928          PT2(1) = PT2I(1)-HPST*CFE2
8929          PT2(2) = PT2I(2)-HPST*SFE2
8930       ELSE
8931          PP1(1) = PP1I(1)+HPSP*CFE1
8932          PP1(2) = PP1I(2)+HPSP*SFE1
8933          PT1(1) = PT1I(1)-HPSP*CFE1
8934          PT1(2) = PT1I(2)-HPSP*SFE1
8935          PP2(1) = PP2I(1)+HPST*CFE2
8936          PP2(2) = PP2I(2)+HPST*SFE2
8937          PT2(1) = PT2I(1)-HPST*CFE2
8938          PT2(2) = PT2I(2)-HPST*SFE2
8939       ENDIF
8940
8941 * put partons on mass shell
8942       XMP1 = 0.0D0
8943       XMT1 = 0.0D0
8944       IF (JMSHL.EQ.1) THEN
8945
8946          XMP1 = PYMASS(IFPR1)
8947          XMT1 = PYMASS(IFTA1)
8948
8949       ENDIF
8950       CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8951       IF (IREJ1.NE.0) GOTO 2
8952       DO 3 I=1,4
8953          PTOTF(I) = P1(I)+P2(I)
8954          PP1(I)   = P1(I)
8955          PT1(I)   = P2(I)
8956     3 CONTINUE
8957       XMP2 = 0.0D0
8958       XMT2 = 0.0D0
8959       IF (JMSHL.EQ.1) THEN
8960
8961          XMP2 = PYMASS(IFPR2)
8962          XMT2 = PYMASS(IFTA2)
8963
8964       ENDIF
8965       CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8966       IF (IREJ1.NE.0) GOTO 2
8967       DO 4 I=1,4
8968          PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8969          PP2(I)   = P1(I)
8970          PT2(I)   = P2(I)
8971     4 CONTINUE
8972
8973 * check consistency
8974       DO 5 I=1,4
8975          DIFF(I) = PTOTI(I)-PTOTF(I)
8976     5 CONTINUE
8977       IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8978      &    (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8979          WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8980          GOTO 9999
8981       ENDIF
8982       PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8983       AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8984       PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8985       AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8986       PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8987       AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8988       PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8989       AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8990       IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8991      &    (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8992      &                                                           THEN
8993          WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8994      &     'GETSPT: inconsistent masses',
8995      &     AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8996 * sr 22.11.00: commented. It should only have inconsistent masses for
8997 * ultrahigh energies due to rounding problems
8998 C        GOTO 9999
8999       ENDIF
9000
9001 * get chain masses
9002       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
9003      &                               +(PP1(3)+PT1(3))**2)
9004       ECH   = PP1(4)+PT1(4)
9005       AM1N  = (ECH+PTOCH)*(ECH-PTOCH)
9006       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
9007      &                               +(PP2(3)+PT2(3))**2)
9008       ECH   = PP2(4)+PT2(4)
9009       AM2N  = (ECH+PTOCH)*(ECH-PTOCH)
9010       IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
9011          IF (IOULEV(1).GT.0)
9012      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
9013      &                              AM1N,AM2N
9014          GOTO 2
9015       ENDIF
9016       AM1N = SQRT(AM1N)
9017       AM2N = SQRT(AM2N)
9018
9019 * check chain masses for very low mass chains
9020       CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
9021      &            AM1N,DUM,-IDCH1,IREJ1)
9022       IF (IREJ1.NE.0) GOTO 2
9023       CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
9024      &            AM2N,DUM,-IDCH2,IREJ2)
9025       IF (IREJ2.NE.0) GOTO 2
9026
9027     7 CONTINUE
9028       IF (AM1N.GT.ZERO) THEN
9029          AM1 = AM1N
9030          AM2 = AM2N
9031       ENDIF
9032       DO 6 I=1,4
9033          PP1I(I)   = PP1(I)
9034          PP2I(I)   = PP2(I)
9035          PT1I(I)   = PT1(I)
9036          PT2I(I)   = PT2(I)
9037     6 CONTINUE
9038
9039       RETURN
9040
9041  9999 CONTINUE
9042       IREJ = 1
9043       RETURN
9044       END
9045
9046 *$ CREATE DT_SAPTRE.FOR
9047 *COPY DT_SAPTRE
9048 *
9049 *===saptre=============================================================*
9050 *
9051       SUBROUTINE DT_SAPTRE(IDX1,IDX2)
9052
9053 ************************************************************************
9054 * p-t sampling for two-resonance systems. ("BAMJET-like" method)       *
9055 *        IDX1,IDX2       indices of resonances ("chains") in DTEVT1    *
9056 * Adopted from the original SAPTRE written by J. Ranft.                *
9057 * This version dated 18.01.95 is written by S. Roesler                 *
9058 ************************************************************************
9059
9060       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9061       SAVE
9062
9063       PARAMETER ( LINP = 10 ,
9064      &            LOUT = 6 ,
9065      &            LDAT = 9 )
9066
9067       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
9068
9069 * event history
9070
9071       PARAMETER (NMXHKK=200000)
9072
9073       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9074      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9075      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9076
9077 * extended event history
9078       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9079      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9080      &                IHIST(2,NMXHKK)
9081
9082 * flags for input different options
9083       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9084       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9085      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9086
9087       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
9088
9089       DATA B3 /4.0D0/
9090
9091       ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
9092       ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
9093       ESMAX  = MIN(ESMAX1,ESMAX2)
9094       IF (ESMAX.LE.0.05D0) RETURN
9095
9096       HMA    = PHKK(5,IDX1)
9097       DO 1 K=1,4
9098          PA1(K) = PHKK(K,IDX1)
9099          PA2(K) = PHKK(K,IDX2)
9100     1 CONTINUE
9101
9102       IF (LEMCCK) THEN
9103          CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
9104          CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
9105       ENDIF
9106
9107       EXEB   = 0.0D0
9108       IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
9109       BEXP   = HMA*(1.0D0-EXEB)/B3
9110       AXEXP  = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
9111       WA     = AXEXP/(BEXP+AXEXP)
9112       XAB    = DT_RNDM(WA)
9113    10 CONTINUE
9114 * ES is the transverse kinetic energy
9115       IF (XAB.LT.WA)THEN
9116         X  = DT_RNDM(WA)
9117         Y  = DT_RNDM(WA)
9118         ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
9119       ELSE
9120         X  = DT_RNDM(Y)
9121         ES = ABS(-LOG(X+TINY7)/B3)
9122       ENDIF
9123       IF (ES.GT.ESMAX) GOTO 10
9124       ES  = ES+HMA
9125 * transverse momentum
9126       HPS = SQRT((ES-HMA)*(ES+HMA))
9127
9128       CALL DT_DSFECF(SFE,CFE)
9129       HPX = HPS*CFE
9130       HPY = HPS*SFE
9131       PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
9132       PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
9133       IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
9134
9135 C     PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
9136 C     PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
9137       PA1(1) = PA1(1)+HPX
9138       PA1(2) = PA1(2)+HPY
9139       PA2(1) = PA2(1)-HPX
9140       PA2(2) = PA2(2)-HPY
9141
9142 * put resonances on mass-shell again
9143       XM1 = PHKK(5,IDX1)
9144       XM2 = PHKK(5,IDX2)
9145       CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
9146       IF (IREJ1.NE.0) RETURN
9147
9148       IF (LEMCCK) THEN
9149          CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
9150          CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
9151          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
9152          IF (IREJ1.NE.0) RETURN
9153       ENDIF
9154
9155       DO 2 K=1,4
9156          PHKK(K,IDX1) = P1(K)
9157          PHKK(K,IDX2) = P2(K)
9158     2 CONTINUE
9159
9160       RETURN
9161       END
9162
9163 *$ CREATE DT_CRONIN.FOR
9164 *COPY DT_CRONIN
9165 *
9166 *===cronin=============================================================*
9167 *
9168       SUBROUTINE DT_CRONIN(INCL)
9169
9170 ************************************************************************
9171 * Cronin-Effect. Multiple scattering of partons at chain ends.         *
9172 *             INCL = 1     multiple sc. in projectile                  *
9173 *                  = 2     multiple sc. in target                      *
9174 * This version dated 05.01.96 is written by S. Roesler.                *
9175 ************************************************************************
9176
9177       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9178       SAVE
9179
9180       PARAMETER ( LINP = 10 ,
9181      &            LOUT = 6 ,
9182      &            LDAT = 9 )
9183
9184       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9185
9186 * event history
9187
9188       PARAMETER (NMXHKK=200000)
9189
9190       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9191      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9192      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9193
9194 * extended event history
9195       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9196      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9197      &                IHIST(2,NMXHKK)
9198
9199 * rejection counter
9200       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9201      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9202      &                IREXCI(3),IRDIFF(2),IRINC
9203
9204 * Glauber formalism: collision properties
9205       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9206      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
9207
9208       DIMENSION R(3),PIN(4),POUT(4),DEV(4)
9209
9210       DO 1 K=1,4
9211          DEV(K) = ZERO
9212     1 CONTINUE
9213
9214       DO 2 I=NPOINT(2),NHKK
9215          IF (ISTHKK(I).LT.0) THEN
9216 * get z-position of the chain
9217             R(1) = VHKK(1,I)*1.0D12
9218             IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
9219             R(2) = VHKK(2,I)*1.0D12
9220             IDXNU = JMOHKK(1,I)
9221             IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
9222      &                             IDXNU = JMOHKK(1,I-1)
9223             IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
9224      &                             IDXNU = JMOHKK(1,I+1)
9225             R(3) = VHKK(3,IDXNU)*1.0D12
9226 * position of target parton the chain is connected to
9227             DO 3 K=1,4
9228                PIN(K) = PHKK(K,I)
9229     3       CONTINUE
9230 * multiple scattering of parton with DTEVT1-index I
9231             CALL DT_CROMSC(PIN,R,POUT,INCL)
9232 **testprint
9233 C           IF (NEVHKK.EQ.5) THEN
9234 C              AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
9235 C              AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
9236 C              AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
9237 C              AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
9238 C              WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
9239 C              WRITE(6,'(A,4E15.5)')'PIN:       ',PIN
9240 C              WRITE(6,'(A,4E15.5)')'POUT:      ',POUT
9241 C           ENDIF
9242 **
9243 * increase accumulator by energy-momentum difference
9244             DO 4 K=1,4
9245                DEV(K)    = DEV(K)+POUT(K)-PIN(K)
9246                PHKK(K,I) = POUT(K)
9247     4       CONTINUE
9248             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9249      &                           PHKK(2,I)**2-PHKK(3,I)**2))
9250          ENDIF
9251     2 CONTINUE
9252
9253 * dump accumulator to momenta of valence partons
9254       NVAL = 0
9255       ETOT = 0.0D0
9256       DO 5 I=NPOINT(2),NHKK
9257          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9258             NVAL = NVAL+1
9259             ETOT = ETOT+PHKK(4,I)
9260          ENDIF
9261     5 CONTINUE
9262 C     WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
9263  1000 FORMAT(1X,'CRONIN :  number of val. partons ',I4,/,
9264      &       9X,4E12.4)
9265       DO 6 I=NPOINT(2),NHKK
9266          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9267             E = PHKK(4,I)
9268             DO 7 K=1,4
9269 C              PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
9270                PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
9271     7       CONTINUE
9272             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9273      &                           PHKK(2,I)**2-PHKK(3,I)**2))
9274          ENDIF
9275     6 CONTINUE
9276
9277       RETURN
9278       END
9279
9280 *$ CREATE DT_CROMSC.FOR
9281 *COPY DT_CROMSC
9282 *
9283 *===cromsc=============================================================*
9284 *
9285       SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
9286
9287 ************************************************************************
9288 * Cronin-Effect. Multiple scattering of one parton passing through     *
9289 * nuclear matter.                                                      *
9290 *            PIN(4)       input 4-momentum of parton                   *
9291 *            POUT(4)      4-momentum of parton after mult. scatt.      *
9292 *            R(3)         spatial position of parton in target nucleus *
9293 *            INCL = 1     multiple sc. in projectile                   *
9294 *                 = 2     multiple sc. in target                       *
9295 * This is a revised version of the original version written by J. Ranft*
9296 * This version dated 17.01.95 is written by S. Roesler.                *
9297 ************************************************************************
9298
9299       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9300       SAVE
9301
9302       PARAMETER ( LINP = 10 ,
9303      &            LOUT = 6 ,
9304      &            LDAT = 9 )
9305
9306       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9307
9308       LOGICAL LSTART
9309
9310 * rejection counter
9311       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9312      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9313      &                IREXCI(3),IRDIFF(2),IRINC
9314
9315 * Glauber formalism: collision properties
9316       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9317      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
9318
9319 * various options for treatment of partons (DTUNUC 1.x)
9320 * (chain recombination, Cronin,..)
9321       LOGICAL LCO2CR,LINTPT
9322       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9323      &                LCO2CR,LINTPT
9324
9325       DIMENSION PIN(4),POUT(4),R(3)
9326
9327       DATA LSTART /.TRUE./
9328
9329       IRCRON(1) = IRCRON(1)+1
9330
9331       IF (LSTART) THEN
9332          WRITE(LOUT,1000) CRONCO
9333  1000    FORMAT(/,1X,'CROMSC:  multiple scattering of chain ends',
9334      &          ' treated',/,10X,'with parameter CRONCO = ',F5.2)
9335          LSTART = .FALSE.
9336       ENDIF
9337
9338       NCBACK = 0
9339       RNCL   = RPROJ
9340       IF (INCL.EQ.2) RNCL = RTARG
9341
9342 * Lorentz-transformation into Lab.
9343       MODE = -(INCL+1)
9344       CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
9345
9346       PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
9347       IF (PTOT.LE.8.0D0) GOTO 9997
9348
9349 * direction cosines of parton before mult. scattering
9350       COSX = PIN(1)/PTOT
9351       COSY = PIN(2)/PTOT
9352       COSZ = PZ/PTOT
9353
9354       RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
9355       IF (RTESQ.GE.-TINY3) GOTO 9999
9356
9357 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
9358 * in the direction of particle motion
9359
9360       A    = COSX*R(1)+COSY*R(2)+COSZ*R(3)
9361       TMP  = A**2-RTESQ
9362       IF (TMP.LT.ZERO) GOTO 9998
9363       DIST = -A+SQRT(TMP)
9364
9365 * multiple scattering angle
9366       THETO = CRONCO*SQRT(DIST)/PTOT
9367       IF (THETO.GT.0.1D0) THETO=0.1D0
9368
9369     1 CONTINUE
9370 * Gaussian sampling of spatial angle
9371       CALL DT_RANNOR(R1,R2)
9372       THETA = ABS(R1*THETO)
9373       IF (THETA.GT.0.3D0) GOTO 9997
9374       CALL DT_DSFECF(SFE,CFE)
9375       COSTH = COS(THETA)
9376       SINTH = SIN(THETA)
9377
9378 * new direction cosines
9379       CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
9380      &                               COSXN,COSYN,COSZN)
9381
9382       POUT(1) = COSXN*PTOT
9383       POUT(2) = COSYN*PTOT
9384       PZ      = COSZN*PTOT
9385 * Lorentz-transformation into nucl.-nucl. cms
9386       MODE = INCL+1
9387       CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
9388
9389 C     IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
9390 C     IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
9391       IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
9392          THETO = THETO/2.0D0
9393          NCBACK = NCBACK+1
9394          IF (MOD(NCBACK,200).EQ.0) THEN
9395             WRITE(LOUT,1001) THETO,PIN,POUT
9396  1001       FORMAT(1X,'CROMSC: inconsistent scattering angle ',
9397      &             E12.4,/,1X,'        PIN :',4E12.4,/,
9398      &             1X,'       POUT:',4E12.4)
9399             GOTO 9997
9400          ENDIF
9401          GOTO 1
9402       ENDIF
9403
9404       RETURN
9405
9406  9997 IRCRON(2) = IRCRON(2)+1
9407       GOTO 9999
9408  9998 IRCRON(3) = IRCRON(3)+1
9409
9410  9999 CONTINUE
9411       DO 100 K=1,4
9412          POUT(K) = PIN(K)
9413   100 CONTINUE
9414       RETURN
9415       END
9416
9417 *$ CREATE DT_COM2CR.FOR
9418 *COPY DT_COM2CR
9419 *
9420 *===com2sr=============================================================*
9421 *
9422       SUBROUTINE DT_COM2CR
9423
9424 ************************************************************************
9425 * COMbine q-aq chains to Color Ropes (qq-aqaq).                        *
9426 *        CUTOF      parameter determining minimum number of not        *
9427 *                   combined q-aq chains                               *
9428 * This subroutine replaces KKEVCC etc.                                 *
9429 * This version dated 11.01.95 is written by S. Roesler.                *
9430 ************************************************************************
9431
9432       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9433       SAVE
9434
9435       PARAMETER ( LINP = 10 ,
9436      &            LOUT = 6 ,
9437      &            LDAT = 9 )
9438
9439 * event history
9440
9441       PARAMETER (NMXHKK=200000)
9442
9443       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9444      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9445      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9446
9447 * extended event history
9448       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9449      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9450      &                IHIST(2,NMXHKK)
9451
9452 * statistics
9453       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9454      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9455      &                ICEVTG(8,0:30)
9456
9457 * various options for treatment of partons (DTUNUC 1.x)
9458 * (chain recombination, Cronin,..)
9459       LOGICAL LCO2CR,LINTPT
9460       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9461      &                LCO2CR,LINTPT
9462
9463       DIMENSION IDXQA(248),IDXAQ(248)
9464
9465       ICCHAI(1,9) = ICCHAI(1,9)+1
9466       NQA = 0
9467       NAQ = 0
9468 * scan DTEVT1 for q-aq, aq-q chains
9469       DO 10 I=NPOINT(3),NHKK
9470 * skip "chains" which are resonances
9471          IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
9472             MO1 = JMOHKK(1,I)
9473             MO2 = JMOHKK(2,I)
9474             IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
9475 * q-aq, aq-q chain found, keep index
9476                IF (IDHKK(MO1).GT.0) THEN
9477                   NQA = NQA+1
9478                   IDXQA(NQA) = I
9479                ELSE
9480                   NAQ = NAQ+1
9481                   IDXAQ(NAQ) = I
9482                ENDIF
9483             ENDIF
9484          ENDIF
9485    10 CONTINUE
9486
9487 * minimum number of q-aq chains requested for the same projectile/
9488 * target
9489       NCHMIN = IDT_NPOISS(CUTOF)
9490
9491 * combine q-aq chains of the same projectile
9492       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
9493 * combine q-aq chains of the same target
9494       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9495 * combine aq-q chains of the same projectile
9496       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9497 * combine aq-q chains of the same target
9498       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9499
9500       RETURN
9501       END
9502
9503 *$ CREATE DT_SCN4CR.FOR
9504 *COPY DT_SCN4CR
9505 *
9506 *===scn4cr=============================================================*
9507 *
9508       SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9509
9510 ************************************************************************
9511 * SCan q-aq chains for Color Ropes.                                    *
9512 * This version dated 11.01.95 is written by S. Roesler.                *
9513 ************************************************************************
9514
9515       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9516       SAVE
9517
9518       PARAMETER ( LINP = 10 ,
9519      &            LOUT = 6 ,
9520      &            LDAT = 9 )
9521
9522 * event history
9523
9524       PARAMETER (NMXHKK=200000)
9525
9526       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9527      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9528      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9529
9530 * extended event history
9531       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9532      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9533      &                IHIST(2,NMXHKK)
9534
9535       DIMENSION IDXCH(248),IDXJN(248)
9536
9537       DO 1 I=1,NCH
9538          IF (IDXCH(I).GT.0) THEN
9539             NJOIN = 1
9540             IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9541             IDXJN(NJOIN) = I
9542             IF (I.LT.NCH) THEN
9543                DO 2 J=I+1,NCH
9544                   IF (IDXCH(J).GT.0) THEN
9545                      IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9546                      IF (IDXMO.EQ.IDXMO1) THEN
9547                         NJOIN = NJOIN+1
9548                         IDXJN(NJOIN) = J
9549                      ENDIF
9550                   ENDIF
9551     2          CONTINUE
9552             ENDIF
9553             IF (NJOIN.GE.NCHMIN+2) THEN
9554                NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9555                DO 3 J=1,2*NJ,2
9556                   CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9557                   IF (IREJ1.NE.0) GOTO 3
9558                   IDXCH(IDXJN(J))   = 0
9559                   IDXCH(IDXJN(J+1)) = 0
9560     3          CONTINUE
9561             ENDIF
9562          ENDIF
9563     1 CONTINUE
9564
9565       RETURN
9566       END
9567
9568 *$ CREATE DT_JOIN.FOR
9569 *COPY DT_JOIN
9570 *
9571 *===join===============================================================*
9572 *
9573       SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9574
9575 ************************************************************************
9576 * This subroutine joins two q-aq chains to one qq-aqaq chain.          *
9577 *     IDX1, IDX2       DTEVT1 indices of chains to be joined           *
9578 * This version dated 11.01.95 is written by S. Roesler.                *
9579 ************************************************************************
9580
9581       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9582       SAVE
9583
9584       PARAMETER ( LINP = 10 ,
9585      &            LOUT = 6 ,
9586      &            LDAT = 9 )
9587
9588 * event history
9589
9590       PARAMETER (NMXHKK=200000)
9591
9592       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9593      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9594      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9595
9596 * extended event history
9597       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9598      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9599      &                IHIST(2,NMXHKK)
9600
9601 * flags for input different options
9602       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9603       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9604      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9605
9606 * statistics
9607       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9608      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9609      &                ICEVTG(8,0:30)
9610
9611       DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9612
9613       IREJ   = 0
9614
9615       IDX(1) = IDX1
9616       IDX(2) = IDX2
9617       DO 1 I=1,2
9618          DO 2 J=1,2
9619             MO(I,J) = JMOHKK(J,IDX(I))
9620             ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9621     2    CONTINUE
9622     1 CONTINUE
9623
9624 * check consistency
9625       IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9626      &    (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9627      &    ((ID(1,1)*ID(2,1)).LT.0).OR.
9628      &    ((ID(1,2)*ID(2,2)).LT.0)) THEN
9629          WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9630      &                    MO(2,2)
9631  1000    FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9632      &             2I5,' chain ',I4,':',2I5)
9633       ENDIF
9634
9635 * join chains
9636       DO 3 K=1,4
9637          PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9638          PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9639     3 CONTINUE
9640       IF1  = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9641       IF2  = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9642       IST1 = ISTHKK(MO(1,1))
9643       IST2 = ISTHKK(MO(1,2))
9644
9645 * put partons again on mass shell
9646       XM1 = 0.0D0
9647       XM2 = 0.0D0
9648       IF (IMSHL.EQ.1) THEN
9649
9650          XM1 = PYMASS(IF1)
9651          XM2 = PYMASS(IF2)
9652
9653       ENDIF
9654       CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9655       IF (IREJ1.NE.0) GOTO 9999
9656       DO 4 I=1,4
9657          PP(I) = P1(I)
9658          PT(I) = P2(I)
9659     4 CONTINUE
9660
9661 * store new partons in DTEVT1
9662       CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9663      &                                                       0,0,0)
9664       CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9665      &                                                       0,0,0)
9666       DO 5 K=1,4
9667          PCH(K) = PP(K)+PT(K)
9668     5 CONTINUE
9669
9670 * check new chain for lower mass limit
9671       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9672          AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9673          CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9674      &               AMCH,AMCHN,3,IREJ1)
9675          IF (IREJ1.NE.0) THEN
9676             NHKK = NHKK-2
9677             GOTO 9999
9678          ENDIF
9679       ENDIF
9680
9681       ICCHAI(2,9) = ICCHAI(2,9)+1
9682 * store new chain in DTEVT1
9683       KCH = 191
9684       CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9685       IDHKK(IDX(1)) = 22222
9686       IDHKK(IDX(2)) = 22222
9687 * special treatment for space-time coordinates
9688       DO 6 K=1,4
9689          VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9690          WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9691     6 CONTINUE
9692       RETURN
9693
9694  9999 CONTINUE
9695       IREJ = 1
9696       RETURN
9697       END
9698 *$ CREATE DT_XSGLAU.FOR
9699 *COPY DT_XSGLAU
9700 *
9701 *===xsglau=============================================================*
9702 *
9703       SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9704
9705 ************************************************************************
9706 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9707 * Glauber's approach.                                                  *
9708 *  NA / NB     mass numbers of proj./target nuclei                     *
9709 *  JJPROJ      bamjet-index of projectile (=1 in case of proj.nucleus) *
9710 *  XI,Q2I,ECMI kinematical variables x, Q^2, E_cm                      *
9711 *  IE,IQ       indices of energy and virtuality (the latter for gamma  *
9712 *              projectiles only)                                       *
9713 *  NIDX        index of projectile/target nucleus                      *
9714 * This version dated 17.3.98  is written by S. Roesler                 *
9715 ************************************************************************
9716
9717       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9718       SAVE
9719
9720       PARAMETER ( LINP = 10 ,
9721      &            LOUT = 6 ,
9722      &            LDAT = 9 )
9723
9724       COMPLEX*16 CZERO,CONE,CTWO
9725       CHARACTER*12 CFILE
9726       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9727      &           ONETHI=ONE/THREE,TINY25=1.0D-25)
9728       PARAMETER (TWOPI  = 6.283185307179586454D+00,
9729      &           PI     = TWOPI/TWO,
9730      &           GEV2MB = 0.38938D0,
9731      &           GEV2FM = 0.1972D0,
9732      &           ALPHEM = ONE/137.0D0,
9733 * proton mass
9734      &           AMP    = 0.938D0,
9735      &           AMP2   = AMP**2,
9736 * approx. nucleon radius
9737      &           RNUCLE = 1.12D0)
9738
9739 * particle properties (BAMJET index convention)
9740       CHARACTER*8  ANAME
9741       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9742      &                IICH(210),IIBAR(210),K1(210),K2(210)
9743
9744       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9745
9746       PARAMETER ( MAXNCL = 260,
9747
9748      &            MAXVQU = MAXNCL,
9749      &            MAXSQU = 20*MAXVQU,
9750      &            MAXINT = MAXVQU+MAXSQU)
9751
9752 * Glauber formalism: parameters
9753       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9754      &                BMAX(NCOMPX),BSTEP(NCOMPX),
9755      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9756      &                NSITEB,NSTATB
9757
9758 * Glauber formalism: cross sections
9759       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9760      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9761      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9762      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9763      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9764      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9765      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9766      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9767      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9768      &                BSLOPE,NEBINI,NQBINI
9769
9770 * Glauber formalism: flags and parameters for statistics
9771       LOGICAL LPROD
9772       CHARACTER*8 CGLB
9773       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9774
9775 * nucleon-nucleon event-generator
9776       CHARACTER*8 CMODEL
9777       LOGICAL LPHOIN
9778       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9779
9780 * VDM parameter for photon-nucleus interactions
9781       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9782
9783 * parameters for hA-diffraction
9784       COMMON /DTDIHA/ DIBETA,DIALPH
9785
9786       COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9787      &           OMPP11,OMPP12,OMPP21,OMPP22,
9788      &           DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9789      &           PPTMP1,PPTMP2
9790       COMPLEX*16 C,CA,CI
9791       DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9792      &          COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9793      &          BPROD(KSITEB)
9794
9795       PARAMETER (NPOINT=16)
9796       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9797
9798       LOGICAL LFIRST,LOPEN
9799       DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9800
9801       NTARG = ABS(NIDX)
9802 * for quasi-elastic neutrino scattering set projectile to proton
9803 * it should not have an effect since the whole Glauber-formalism is
9804 * not needed for these interactions..
9805       IF (MCGENE.EQ.4) THEN
9806          IJPROJ = 1
9807       ELSE
9808          IJPROJ = JJPROJ
9809       ENDIF
9810
9811       IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9812          I = INDEX(CGLB,' ')
9813          IF (I.EQ.0) THEN
9814             CFILE = CGLB//'.glb'
9815             OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9816          ELSEIF (I.GT.1) THEN
9817             CFILE = CGLB(1:I-1)//'.glb'
9818             OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9819          ELSE
9820             STOP 'XSGLAU 1'
9821          ENDIF
9822          LOPEN = .TRUE.
9823       ENDIF
9824
9825       CZERO  = DCMPLX(ZERO,ZERO)
9826       CONE   = DCMPLX(ONE,ZERO)
9827       CTWO   = DCMPLX(TWO,ZERO)
9828       NEBINI = IE
9829       NQBINI = IQ
9830
9831 * re-define kinematics
9832       S  = ECMI**2
9833       Q2 = Q2I
9834       X  = XI
9835 *  g(Q2=0)-A, h-A, A-A scattering
9836       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9837          Q2 = 0.0001D0
9838          X  = Q2/(S+Q2-AMP2)
9839 *  g(Q2>0)-A scattering
9840       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9841          X  = Q2/(S+Q2-AMP2)
9842       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9843          Q2 = (S-AMP2)*X/(ONE-X)
9844       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9845          S  = Q2*(ONE-X)/X+AMP2
9846       ELSE
9847          WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9848          STOP
9849       ENDIF
9850       ECMNN(IE) = SQRT(S)
9851       Q2G(IQ)   = Q2
9852       XNU = (S+Q2-AMP2)/(TWO*AMP)
9853
9854 * parameters determining statistics in evaluating Glauber-xsection
9855       NSTATB = JSTATB
9856       NSITEB = JBINSB
9857       IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9858
9859 * set up interaction geometry (common /DTGLAM/)
9860 *  projectile/target radii
9861       RPRNCL = DT_RNCLUS(NA)
9862       RTANCL = DT_RNCLUS(NB)
9863       IF (IJPROJ.EQ.7) THEN
9864          RASH(1) = ZERO
9865          RBSH(NTARG) = RTANCL
9866          BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9867       ELSE
9868          IF (NIDX.LE.-1) THEN
9869             RASH(1)     = RPRNCL
9870             RBSH(NTARG) = RTANCL
9871             BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9872          ELSE
9873             RASH(NTARG) = RPRNCL
9874             RBSH(1)     = RTANCL
9875             BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9876          ENDIF
9877       ENDIF
9878 *  maximum impact-parameter
9879       BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9880
9881 * slope, rho ( Re(f(0))/Im(f(0)) )
9882       IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9883          IF (MCGENE.EQ.2) THEN
9884             ZERO1 = ZERO
9885             CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9886      &                                                   BSLOPE,0)
9887          ELSE
9888             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9889          ENDIF
9890          IF (ECMNN(IE).LE.3.0D0) THEN
9891             ROSH = -0.43D0
9892          ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9893             ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9894          ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9895             ROSH = 0.1D0
9896          ENDIF
9897       ELSEIF (IJPROJ.EQ.7) THEN
9898          ROSH = 0.1D0
9899       ELSE
9900          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9901          ROSH   = 0.01D0
9902       ENDIF
9903
9904 * projectile-nucleon xsection (in fm)
9905       IF (IJPROJ.EQ.7) THEN
9906          SIGSH = DT_SIGVP(X,Q2)/10.0D0
9907       ELSE
9908          ELAB  = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9909          PLAB  = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9910 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9911          DUMZER = ZERO
9912          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9913          SIGSH = SIGSH/10.0D0
9914       ENDIF
9915
9916 * parameters for projectile diffraction (hA scattering only)
9917       IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9918      &                               .AND.(DIBETA.GE.ZERO)) THEN
9919          ZERO1 = ZERO
9920          CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9921 C        DIBETA = SDIF1/STOT
9922          DIBETA = 0.2D0
9923          DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9924          IF (DIBETA.LE.ZERO) THEN
9925             ALPGAM = ONE
9926          ELSE
9927             ALPGAM = DIALPH/DIGAMM
9928          ENDIF
9929          FACDI1 = ONE-ALPGAM
9930          FACDI2 = ONE+ALPGAM
9931          FACDI  = SQRT(FACDI1*FACDI2)
9932          WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9933       ELSE
9934          DIBETA = -1.0D0
9935          DIALPH = ZERO
9936          DIGAMM = ZERO
9937          FACDI1 = ZERO
9938          FACDI2 = 2.0D0
9939          FACDI  = ZERO
9940       ENDIF
9941
9942 * initializations
9943       DO 10 I=1,NSITEB
9944          BSITE( 0,IQ,NTARG,I) = ZERO
9945          BSITE(IE,IQ,NTARG,I) = ZERO
9946          BPROD(I) = ZERO
9947    10 CONTINUE
9948       STOT  = ZERO
9949       STOT2 = ZERO
9950       SELA  = ZERO
9951       SELA2 = ZERO
9952       SQEP  = ZERO
9953       SQEP2 = ZERO
9954       SQET  = ZERO
9955       SQET2 = ZERO
9956       SQE2  = ZERO
9957       SQE22 = ZERO
9958       SPRO  = ZERO
9959       SPRO2 = ZERO
9960       SDEL  = ZERO
9961       SDEL2 = ZERO
9962       SDQE  = ZERO
9963       SDQE2 = ZERO
9964       FACN   = ONE/DBLE(NSTATB)
9965
9966       IPNT = 0
9967       RPNT = ZERO
9968
9969 *  initialize Gauss-integration for photon-proj.
9970       JPOINT = 1
9971       IF (IJPROJ.EQ.7) THEN
9972          IF (INTRGE(1).EQ.1) THEN
9973             AMLO2 = (3.0D0*AAM(13))**2
9974          ELSEIF (INTRGE(1).EQ.2) THEN
9975             AMLO2 = AAM(33)**2
9976          ELSE
9977             AMLO2 = AAM(96)**2
9978          ENDIF
9979          IF (INTRGE(2).EQ.1) THEN
9980             AMHI2 = S/TWO
9981          ELSEIF (INTRGE(2).EQ.2) THEN
9982             AMHI2 = S/4.0D0
9983          ELSE
9984             AMHI2 = S
9985          ENDIF
9986          AMHI20 = (ECMNN(IE)-AMP)**2
9987          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9988          XAMLO = LOG( AMLO2+Q2 )
9989          XAMHI = LOG( AMHI2+Q2 )
9990 **PHOJET105a
9991 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9992 **PHOJET112
9993
9994          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9995
9996 **
9997          JPOINT = NPOINT
9998 * ratio direct/total photon-nucleon xsection
9999          CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
10000       ENDIF
10001
10002 * read pre-initialized profile-function from file
10003       IF (IOGLB.EQ.1) THEN
10004          READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
10005          IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
10006             WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
10007      &                             NA,NB,NSTATB,NSITEB
10008  1000       FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
10009      &             ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
10010      &             ' (NA,NB,NSTATB,NSITEB) ',4I10)
10011             STOP
10012          ENDIF
10013          IF (LFIRST) WRITE(LOUT,1001) CFILE
10014  1001    FORMAT(/,' XSGLAU: impact parameter distribution read from ',
10015      &          'file ',A12,/)
10016          READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
10017      &                         XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
10018      &                         XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10019          READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
10020      &                         XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
10021      &                         XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10022          NLINES = INT(DBLE(NSITEB)/7.0D0)
10023          IF (NLINES.GT.0) THEN
10024             DO 21 I=1,NLINES
10025                ISTART = 7*I-6
10026                READ(LDAT,'(7E11.4)')
10027      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10028    21       CONTINUE
10029          ENDIF
10030          ISTART = 7*NLINES+1
10031          IF (ISTART.LE.NSITEB) THEN
10032             READ(LDAT,'(7E11.4)')
10033      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10034          ENDIF
10035          LFIRST = .FALSE.
10036          GOTO 100
10037 * variable projectile/target/energy runs:
10038 * read pre-initialized profile-functions from file
10039       ELSEIF (IOGLB.EQ.100) THEN
10040          CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
10041          GOTO 100
10042       ENDIF
10043
10044 * cross sections averaged over NSTATB nucleon configurations
10045       DO 11 IS=1,NSTATB
10046 C        IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
10047          STOTN = ZERO
10048          SELAN = ZERO
10049          SQEPN = ZERO
10050          SQETN = ZERO
10051          SQE2N = ZERO
10052          SPRON = ZERO
10053          SDELN = ZERO
10054          SDQEN = ZERO
10055
10056          IF (NIDX.LE.-1) THEN
10057             CALL DT_CONUCL(COOP1,NA,RASH(1),0)
10058             CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
10059             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10060                CALL DT_CONUCL(COOP2,NA,RASH(1),0)
10061                CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
10062             ENDIF
10063          ELSE
10064             CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
10065             CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
10066             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10067                CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
10068                CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
10069             ENDIF
10070          ENDIF
10071
10072 *  integration over impact parameter B
10073          DO 12 IB=1,NSITEB-1
10074             STOTB = ZERO
10075             SELAB = ZERO
10076             SQEPB = ZERO
10077             SQETB = ZERO
10078             SQE2B = ZERO
10079             SPROB = ZERO
10080             SDIR  = ZERO
10081             SDELB = ZERO
10082             SDQEB = ZERO
10083             B     = DBLE(IB)*BSTEP(NTARG)
10084             FACB  = 10.0D0*TWOPI*B*BSTEP(NTARG)
10085
10086 *   integration over M_V^2 for photon-proj.
10087             DO 14 IM=1,JPOINT
10088                PP11(1) = CONE
10089                PP12(1) = CONE
10090                PP21(1) = CONE
10091                PP22(1) = CONE
10092                IF (IJPROJ.EQ.7) THEN
10093                   DO 13 K=2,NB
10094                      PP11(K) = CONE
10095                      PP12(K) = CONE
10096                      PP21(K) = CONE
10097                      PP22(K) = CONE
10098    13             CONTINUE
10099                ENDIF
10100                SHI  = ZERO
10101                FACM = ONE
10102                DCOH = 1.0D10
10103
10104                IF (IJPROJ.EQ.7) THEN
10105                   AMV2 = EXP(ABSZX(IM))-Q2
10106                   AMV  = SQRT(AMV2)
10107                   IF (AMV2.LT.16.0D0) THEN
10108                      R = TWO
10109                   ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
10110                      R = 10.0D0/3.0D0
10111                   ELSE
10112                      R = 11.0D0/3.0D0
10113                   ENDIF
10114 *    define M_V dependent properties of nucleon scattering amplitude
10115 *     V_M-nucleon xsection
10116                   SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
10117                   SIGMV  = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
10118 *     slope-parametrisation a la Kaidalov
10119                   BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
10120      &                           +0.25D0*LOG(S/(AMV2+Q2)))
10121 *    coherence length
10122                   IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
10123 *    integration weight factor
10124                   FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
10125      &                  R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
10126                ENDIF
10127                GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10128                GAM = GSH
10129                IF (IJPROJ.EQ.7) THEN
10130                   RCA = GAM*SIGMV/TWOPI
10131                ELSE
10132                   RCA = GAM*SIGSH/TWOPI
10133                ENDIF
10134                FCA = -ROSH*RCA
10135                CA  = DCMPLX(RCA,FCA)
10136                CI  = CONE
10137
10138                DO 15 INA=1,NA
10139                   KK1  = 1
10140                   INT1 = 1
10141                   KK2  = 1
10142                   INT2 = 1
10143                   DO 16 INB=1,NB
10144 *    photon-projectile: check for supression by coherence length
10145                      IF (IJPROJ.EQ.7) THEN
10146                         IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
10147                            KK1  = INB
10148                            INT1 = INT1+1
10149                         ENDIF
10150                         IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
10151                            KK2  = INB
10152                            INT2 = INT2+1
10153                         ENDIF
10154                      ENDIF
10155
10156                      X11 = B+COOT1(1,INB)-COOP1(1,INA)
10157                      Y11 =   COOT1(2,INB)-COOP1(2,INA)
10158                      XY11 = GAM*(X11*X11+Y11*Y11)
10159                      IF (XY11.LE.15.0D0) THEN
10160                         C = CONE-CA*EXP(-XY11)
10161                         AR = DBLE(PP11(INT1))
10162                         AI = DIMAG(PP11(INT1))
10163                         IF (ABS(AR).LT.TINY25) AR = ZERO
10164                         IF (ABS(AI).LT.TINY25) AI = ZERO
10165                         PP11(INT1) = DCMPLX(AR,AI)
10166                         PP11(INT1) = PP11(INT1)*C
10167                         AR  = DBLE(C)
10168                         AI  = DIMAG(C)
10169                         SHI = SHI+LOG(AR*AR+AI*AI)
10170                      ENDIF
10171                      IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10172                         X12 = B+COOT2(1,INB)-COOP1(1,INA)
10173                         Y12 =   COOT2(2,INB)-COOP1(2,INA)
10174                         XY12 = GAM*(X12*X12+Y12*Y12)
10175                         IF (XY12.LE.15.0D0) THEN
10176                            C = CONE-CA*EXP(-XY12)
10177                            AR = DBLE(PP12(INT2))
10178                            AI = DIMAG(PP12(INT2))
10179                            IF (ABS(AR).LT.TINY25) AR = ZERO
10180                            IF (ABS(AI).LT.TINY25) AI = ZERO
10181                            PP12(INT2) = DCMPLX(AR,AI)
10182                            PP12(INT2) = PP12(INT2)*C
10183                         ENDIF
10184                         X21 = B+COOT1(1,INB)-COOP2(1,INA)
10185                         Y21 =   COOT1(2,INB)-COOP2(2,INA)
10186                         XY21 = GAM*(X21*X21+Y21*Y21)
10187                         IF (XY21.LE.15.0D0) THEN
10188                            C = CONE-CA*EXP(-XY21)
10189                            AR = DBLE(PP21(INT1))
10190                            AI = DIMAG(PP21(INT1))
10191                            IF (ABS(AR).LT.TINY25) AR = ZERO
10192                            IF (ABS(AI).LT.TINY25) AI = ZERO
10193                            PP21(INT1) = DCMPLX(AR,AI)
10194                            PP21(INT1) = PP21(INT1)*C
10195                         ENDIF
10196                         X22 = B+COOT2(1,INB)-COOP2(1,INA)
10197                         Y22 =   COOT2(2,INB)-COOP2(2,INA)
10198                         XY22 = GAM*(X22*X22+Y22*Y22)
10199                         IF (XY22.LE.15.0D0) THEN
10200                            C = CONE-CA*EXP(-XY22)
10201                            AR = DBLE(PP22(INT2))
10202                            AI = DIMAG(PP22(INT2))
10203                            IF (ABS(AR).LT.TINY25) AR = ZERO
10204                            IF (ABS(AI).LT.TINY25) AI = ZERO
10205                            PP22(INT2) = DCMPLX(AR,AI)
10206                            PP22(INT2) = PP22(INT2)*C
10207                         ENDIF
10208                      ENDIF
10209    16             CONTINUE
10210    15          CONTINUE
10211
10212                OMPP11 = CZERO
10213                OMPP21 = CZERO
10214                DIPP11 = CZERO
10215                DIPP21 = CZERO
10216                DO 17 K=1,INT1
10217                   IF (PP11(K).EQ.CZERO) THEN
10218                      PPTMP1 = CZERO
10219                      PPTMP2 = CZERO
10220                   ELSE
10221                      PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
10222                      PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
10223                   ENDIF
10224                   AVDIPP = 0.5D0*
10225      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10226                   OMPP11 = OMPP11+AVDIPP
10227 C                 OMPP11 = OMPP11+(CONE-PP11(K))
10228                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10229                   DIPP11 = DIPP11+AVDIPP
10230                   IF (PP21(K).EQ.CZERO) THEN
10231                      PPTMP1 = CZERO
10232                      PPTMP2 = CZERO
10233                   ELSE
10234                      PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
10235                      PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
10236                   ENDIF
10237                   AVDIPP = 0.5D0*
10238      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10239                   OMPP21 = OMPP21+AVDIPP
10240 C                 OMPP21 = OMPP21+(CONE-PP21(K))
10241                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10242                   DIPP21 = DIPP21+AVDIPP
10243    17          CONTINUE
10244                OMPP12 = CZERO
10245                OMPP22 = CZERO
10246                DIPP12 = CZERO
10247                DIPP22 = CZERO
10248                DO 18 K=1,INT2
10249                   IF (PP12(K).EQ.CZERO) THEN
10250                      PPTMP1 = CZERO
10251                      PPTMP2 = CZERO
10252                   ELSE
10253                      PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
10254                      PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
10255                   ENDIF
10256                   AVDIPP = 0.5D0*
10257      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10258                   OMPP12 = OMPP12+AVDIPP
10259 C                 OMPP12 = OMPP12+(CONE-PP12(K))
10260                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10261                   DIPP12 = DIPP12+AVDIPP
10262                   IF (PP22(K).EQ.CZERO) THEN
10263                      PPTMP1 = CZERO
10264                      PPTMP2 = CZERO
10265                   ELSE
10266                      PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
10267                      PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
10268                   ENDIF
10269                   AVDIPP = 0.5D0*
10270      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10271                   OMPP22 = OMPP22+AVDIPP
10272 C                 OMPP22 = OMPP22+(CONE-PP22(K))
10273                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10274                   DIPP22 = DIPP22+AVDIPP
10275    18          CONTINUE
10276
10277                SPROM = ONE-EXP(SHI)
10278                SPROB = SPROB+FACM*SPROM
10279                IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10280                   STOTM = DBLE(OMPP11+OMPP22)
10281                   SELAM = DBLE(OMPP11*DCONJG(OMPP22))
10282                   SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
10283                   SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
10284                   SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
10285                   SDELM = DBLE(DIPP11*DCONJG(DIPP22))
10286                   SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
10287                   STOTB = STOTB+FACM*STOTM
10288                   SELAB = SELAB+FACM*SELAM
10289                   SDELB = SDELB+FACM*SDELM
10290                   IF (NB.GT.1) THEN
10291                      SQEPB = SQEPB+FACM*SQEPM
10292                      SDQEB = SDQEB+FACM*SDQEM
10293                   ENDIF
10294                   IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
10295                   IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
10296                   IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
10297                ENDIF
10298
10299    14       CONTINUE
10300
10301             STOTN = STOTN+FACB*STOTB
10302             SELAN = SELAN+FACB*SELAB
10303             SQEPN = SQEPN+FACB*SQEPB
10304             SQETN = SQETN+FACB*SQETB
10305             SQE2N = SQE2N+FACB*SQE2B
10306             SPRON = SPRON+FACB*SPROB
10307             SDELN = SDELN+FACB*SDELB
10308             SDQEN = SDQEN+FACB*SDQEB
10309
10310             IF (IJPROJ.EQ.7) THEN
10311                BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
10312             ELSE
10313                IF (DIBETA.GT.ZERO) THEN
10314                   BPROD(IB+1)= BPROD(IB+1)
10315      &                        +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
10316                ELSE
10317                   BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
10318                ENDIF
10319             ENDIF
10320
10321    12    CONTINUE
10322
10323          STOT  = STOT +FACN*STOTN
10324          STOT2 = STOT2+FACN*STOTN**2
10325          SELA  = SELA +FACN*SELAN
10326          SELA2 = SELA2+FACN*SELAN**2
10327          SQEP  = SQEP +FACN*SQEPN
10328          SQEP2 = SQEP2+FACN*SQEPN**2
10329          SQET  = SQET +FACN*SQETN
10330          SQET2 = SQET2+FACN*SQETN**2
10331          SQE2  = SQE2 +FACN*SQE2N
10332          SQE22 = SQE22+FACN*SQE2N**2
10333          SPRO  = SPRO +FACN*SPRON
10334          SPRO2 = SPRO2+FACN*SPRON**2
10335          SDEL  = SDEL +FACN*SDELN
10336          SDEL2 = SDEL2+FACN*SDELN**2
10337          SDQE  = SDQE +FACN*SDQEN
10338          SDQE2 = SDQE2+FACN*SDQEN**2
10339
10340    11 CONTINUE
10341
10342 * final cross sections
10343 * 1) total
10344       XSTOT(IE,IQ,NTARG) = STOT
10345       IF (IJPROJ.EQ.7)
10346      &   XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
10347 * 2) elastic
10348       XSELA(IE,IQ,NTARG) = SELA
10349 * 3) quasi-el.: A+B-->A+X (excluding 2)
10350       XSQEP(IE,IQ,NTARG) = SQEP
10351 * 4) quasi-el.: A+B-->X+B (excluding 2)
10352       XSQET(IE,IQ,NTARG) = SQET
10353 * 5) quasi-el.: A+B-->X (excluding 2-4)
10354       XSQE2(IE,IQ,NTARG) = SQE2
10355 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
10356       IF (SDEL.GT.ZERO) THEN
10357          XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
10358       ELSE
10359          XSPRO(IE,IQ,NTARG) = SPRO
10360       ENDIF
10361 * 7) projectile diffraction (el. scatt. off target)
10362       XSDEL(IE,IQ,NTARG) = SDEL
10363 * 8) projectile diffraction (quasi-el. scatt. off target)
10364       XSDQE(IE,IQ,NTARG) = SDQE
10365 *  stat. errors
10366       XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
10367       XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
10368       XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
10369       XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
10370       XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
10371       XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
10372       XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
10373       XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
10374
10375       IF (IJPROJ.EQ.7) THEN
10376          BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
10377      &          -XSQEP(IE,IQ,NTARG)
10378       ELSE
10379          BNORM = XSPRO(IE,IQ,NTARG)
10380       ENDIF
10381       DO 19 I=2,NSITEB
10382          BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
10383          IF ((IE.EQ.1).AND.(IQ.EQ.1))
10384      &      BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
10385    19 CONTINUE
10386
10387 * write profile function data into file
10388       IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
10389          WRITE(LDAT,'(5I10,1P,E15.5)')
10390      &      IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
10391          WRITE(LDAT,'(1P,6E12.5)')
10392      &      XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
10393      &      XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10394          WRITE(LDAT,'(1P,6E12.5)')
10395      &      XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
10396      &      XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10397          NLINES = INT(DBLE(NSITEB)/7.0D0)
10398          IF (NLINES.GT.0) THEN
10399             DO 20 I=1,NLINES
10400                ISTART = 7*I-6
10401                WRITE(LDAT,'(1P,7E11.4)')
10402      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10403    20       CONTINUE
10404          ENDIF
10405          ISTART = 7*NLINES+1
10406          IF (ISTART.LE.NSITEB) THEN
10407             WRITE(LDAT,'(1P,7E11.4)')
10408      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10409          ENDIF
10410       ENDIF
10411
10412   100 CONTINUE
10413
10414 C     IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
10415
10416       RETURN
10417       END
10418
10419 *$ CREATE DT_GETBXS.FOR
10420 *COPY DT_GETBXS
10421 *
10422 *===getbxs=============================================================*
10423 *
10424       SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
10425
10426 ************************************************************************
10427 * Biasing in impact parameter space.                                   *
10428 *     XSFRAC = 0 :  BLO    - minimum impact parameter  (input)         *
10429 *                   BHI    - maximum impact parameter  (input)         *
10430 *                   XSFRAC - fraction of cross section corresponding   *
10431 *                            to impact parameter range (BLO,BHI)       *
10432 *                                                      (output)        *
10433 *     XSFRAC > 0 :  XSFRAC - fraction of cross section (input)         *
10434 *                   BHI    - maximum impact parameter giving requested *
10435 *                            fraction of cross section in impact       *
10436 *                            parameter range (0,BMAX)  (output)        *
10437 * This version dated 17.03.00  is written by S. Roesler                *
10438 ************************************************************************
10439
10440       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10441       SAVE
10442
10443       PARAMETER ( LINP = 10 ,
10444      &            LOUT = 6 ,
10445      &            LDAT = 9 )
10446
10447       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10448
10449 * Glauber formalism: parameters
10450       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10451      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10452      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10453      &                NSITEB,NSTATB
10454
10455       NTARG = ABS(NIDX)
10456       IF (XSFRAC.LE.0.0D0) THEN
10457          ILO    = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
10458          IHI    = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
10459          IF (ILO.GE.IHI) THEN
10460             XSFRAC = 0.0D0
10461             RETURN
10462          ENDIF
10463          IF (ILO.EQ.NSITEB-1) THEN
10464             FRCLO = BSITE(0,1,NTARG,NSITEB)
10465          ELSE
10466             FRCLO = BSITE(0,1,NTARG,ILO+1)
10467      &              +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
10468      &              *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
10469          ENDIF
10470          IF (IHI.EQ.NSITEB-1) THEN
10471             FRCHI = BSITE(0,1,NTARG,NSITEB)
10472          ELSE
10473             FRCHI = BSITE(0,1,NTARG,IHI+1)
10474      &              +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
10475      &              *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
10476          ENDIF
10477          XSFRAC = FRCHI-FRCLO
10478       ELSE
10479          BLO = 0.0D0
10480          BHI = BMAX(NTARG)
10481          DO 1 I=1,NSITEB-1
10482             IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
10483                FAC = (XSFRAC              -BSITE(0,1,NTARG,I))/
10484      &               (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
10485                BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
10486                GOTO 2
10487             ENDIF
10488     1    CONTINUE
10489     2    CONTINUE
10490       ENDIF
10491
10492       RETURN
10493       END
10494
10495 *$ CREATE DT_CONUCL.FOR
10496 *COPY DT_CONUCL
10497 *
10498 *===conucl=============================================================*
10499 *
10500       SUBROUTINE DT_CONUCL(X,N,R,MODE)
10501
10502 ************************************************************************
10503 * Calculation of coordinates of nucleons within nuclei.                *
10504 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10505 *        N / R    number of nucleons / radius of nucleus   (input)     *
10506 *        MODE = 0 coordinates not sorted                               *
10507 *             = 1 coordinates sorted with increasing X(3,i)            *
10508 *             = 2 coordinates sorted with decreasing X(3,i)            *
10509 * This version dated 26.10.95 is revised by S. Roesler                 *
10510 ************************************************************************
10511
10512       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10513       SAVE
10514
10515       PARAMETER ( LINP = 10 ,
10516      &            LOUT = 6 ,
10517      &            LDAT = 9 )
10518
10519       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10520      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10521
10522       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10523
10524       PARAMETER (NSRT=10)
10525       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10526       DIMENSION X(3,N),XTMP(3,260)
10527
10528       CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10529
10530       IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10531          K = 0
10532          DO 1 I=1,NSRT
10533             IF (MODE.EQ.2) THEN
10534                ISRT = NSRT+1-I
10535             ELSE
10536                ISRT = I
10537             ENDIF
10538             K1 = K
10539             DO 2 J=1,ICSRT(ISRT)
10540                K = K+1
10541                X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10542                X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10543                X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10544     2       CONTINUE
10545             IF (ICSRT(ISRT).GT.1) THEN
10546                I0 = K1+1
10547                I1 = K
10548                CALL DT_SORT(X,N,I0,I1,MODE)
10549             ENDIF
10550     1    CONTINUE
10551       ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10552          DO 3 I=1,N
10553             X(1,I) = XTMP(1,I)
10554             X(2,I) = XTMP(2,I)
10555             X(3,I) = XTMP(3,I)
10556     3    CONTINUE
10557          CALL DT_SORT(X,N,1,N,MODE)
10558       ELSE
10559          DO 4 I=1,N
10560             X(1,I) = XTMP(1,I)
10561             X(2,I) = XTMP(2,I)
10562             X(3,I) = XTMP(3,I)
10563     4    CONTINUE
10564       ENDIF
10565
10566       RETURN
10567       END
10568
10569 *$ CREATE DT_COORDI.FOR
10570 *COPY DT_COORDI
10571 *
10572 *===coordi=============================================================*
10573 *
10574       SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10575
10576 ************************************************************************
10577 * Calculation of coordinates of nucleons within nuclei.                *
10578 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10579 *        N / R    number of nucleons / radius of nucleus   (input)     *
10580 * Based on the original version by Shmakov et al.                      *
10581 * This version dated 26.10.95 is revised by S. Roesler                 *
10582 ************************************************************************
10583
10584       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10585       SAVE
10586
10587       PARAMETER ( LINP = 10 ,
10588      &            LOUT = 6 ,
10589      &            LDAT = 9 )
10590
10591       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10592      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10593
10594       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10595
10596       LOGICAL LSTART
10597
10598       PARAMETER (NSRT=10)
10599       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10600       DIMENSION X(3,260),WD(4),RD(3)
10601
10602       DATA PDIF/0.545D0/,R2MIN/0.16D0/
10603       DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10604       DATA RD /2.09D0, 0.935D0, 0.697D0/
10605
10606       X1SUM = ZERO
10607       X2SUM = ZERO
10608       X3SUM = ZERO
10609
10610       IF (N.EQ.1) THEN
10611          X(1,1) = ZERO
10612          X(2,1) = ZERO
10613          X(3,1) = ZERO
10614       ELSEIF (N.EQ.2) THEN
10615          EPS = DT_RNDM(RD(1))
10616          DO 30 I=1,3
10617             IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10618    30    CONTINUE
10619    40    CONTINUE
10620          DO 50 J=1,3
10621             CALL DT_RANNOR(X1,X2)
10622             X(J,1) = RD(I)*X1
10623             X(J,2) = -X(J,1)
10624    50    CONTINUE
10625       ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10626          SIGMA = R/SQRTWO
10627          LSTART = .TRUE.
10628          CALL DT_RANNOR(X3,X4)
10629          DO 100 I=1,N
10630             CALL DT_RANNOR(X1,X2)
10631             X(1,I) = SIGMA*X1
10632             X(2,I) = SIGMA*X2
10633             IF (LSTART) GOTO 80
10634             X(3,I) = SIGMA*X4
10635             CALL DT_RANNOR(X3,X4)
10636             GOTO 90
10637    80       CONTINUE
10638             X(3,I) = SIGMA*X3
10639    90       CONTINUE
10640             LSTART = .NOT.LSTART
10641             X1SUM = X1SUM+X(1,I)
10642             X2SUM = X2SUM+X(2,I)
10643             X3SUM = X3SUM+X(3,I)
10644   100    CONTINUE
10645          X1SUM = X1SUM/DBLE(N)
10646          X2SUM = X2SUM/DBLE(N)
10647          X3SUM = X3SUM/DBLE(N)
10648          DO 101 I=1,N
10649             X(1,I) = X(1,I)-X1SUM
10650             X(2,I) = X(2,I)-X2SUM
10651             X(3,I) = X(3,I)-X3SUM
10652   101    CONTINUE
10653       ELSE
10654
10655 * maximum nuclear radius for coordinate sampling
10656          RMAX = R+4.605D0*PDIF
10657
10658 * initialize pre-sorting
10659          DO 121 I=1,NSRT
10660             ICSRT(I) = 0
10661   121    CONTINUE
10662          DR = TWO*RMAX/DBLE(NSRT)
10663
10664 * sample coordinates for N nucleons
10665          DO 140 I=1,N
10666   120       CONTINUE
10667             RAD = RMAX*(DT_RNDM(DR))**ONETHI
10668             F   = DT_DENSIT(N,RAD,R)
10669             IF (DT_RNDM(RAD).GT.F) GOTO 120
10670 *   theta, phi uniformly distributed
10671             CT  = ONE-TWO*DT_RNDM(F)
10672             ST  = SQRT((ONE-CT)*(ONE+CT))
10673             CALL DT_DSFECF(SFE,CFE)
10674             X(1,I) = RAD*ST*CFE
10675             X(2,I) = RAD*ST*SFE
10676             X(3,I) = RAD*CT
10677 *   ensure that distance between two nucleons is greater than R2MIN
10678             IF (I.LT.2) GOTO 122
10679             I1 = I-1
10680             DO 130 I2=1,I1
10681                DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10682      &                 (X(3,I)-X(3,I2))**2
10683                IF (DIST2.LE.R2MIN) GOTO 120
10684   130       CONTINUE
10685   122       CONTINUE
10686 *   save index according to z-bin
10687             IDXZ        = INT( (X(3,I)+RMAX)/DR )+1
10688             ICSRT(IDXZ) = ICSRT(IDXZ)+1
10689             IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10690             X1SUM = X1SUM+X(1,I)
10691             X2SUM = X2SUM+X(2,I)
10692             X3SUM = X3SUM+X(3,I)
10693   140    CONTINUE
10694          X1SUM = X1SUM/DBLE(N)
10695          X2SUM = X2SUM/DBLE(N)
10696          X3SUM = X3SUM/DBLE(N)
10697          DO 141 I=1,N
10698             X(1,I) = X(1,I)-X1SUM
10699             X(2,I) = X(2,I)-X2SUM
10700             X(3,I) = X(3,I)-X3SUM
10701   141    CONTINUE
10702
10703       ENDIF
10704
10705       RETURN
10706       END
10707
10708 *$ CREATE DT_DENSIT.FOR
10709 *COPY DT_DENSIT
10710 *
10711 *===densit=============================================================*
10712 *
10713       DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10714
10715       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10716       SAVE
10717
10718       PARAMETER ( LINP = 10 ,
10719      &            LOUT = 6 ,
10720      &            LDAT = 9 )
10721
10722       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10723       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10724      &           PI    = TWOPI/TWO)
10725
10726       DIMENSION R0(18),FNORM(18)
10727       DATA R0 /  ZERO,   ZERO,   ZERO,   ZERO, 2.12D0,
10728      &         2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10729      &         2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10730      &         2.72D0, 2.66D0, 2.79D0/
10731       DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10732      &            .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10733      &            .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10734      &            .1214D+01,.1265D+01,.1318D+01/
10735       DATA PDIF /0.545D0/
10736
10737       DT_DENSIT = ZERO
10738 * shell model
10739       IF (NA.LE.4) THEN
10740          STOP 'DT_DENSIT-0'
10741       ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10742          R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10743          DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10744      &            *EXP(-(R/R1)**2)/FNORM(NA)
10745 * Woods-Saxon
10746       ELSEIF (NA.GT.18) THEN
10747          DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10748       ENDIF
10749
10750       RETURN
10751       END
10752
10753 *$ CREATE DT_RNCLUS.FOR
10754 *COPY DT_RNCLUS
10755 *
10756 *===rnclus=============================================================*
10757 *
10758       DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10759
10760 ************************************************************************
10761 * Nuclear radius for nucleus with mass number N.                       *
10762 * This version dated 26.9.00  is written by S. Roesler                 *
10763 ************************************************************************
10764
10765       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10766       SAVE
10767
10768       PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10769
10770 * nucleon radius
10771       PARAMETER (RNUCLE = 1.12D0)
10772
10773 * nuclear radii for selected nuclei
10774       DIMENSION RADNUC(18)
10775       DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10776      &               2.58D0,2.71D0,2.66D0,2.71D0/
10777
10778       IF (N.LE.18) THEN
10779          IF (RADNUC(N).GT.0.0D0) THEN
10780             DT_RNCLUS = RADNUC(N)
10781          ELSE
10782             DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10783          ENDIF
10784       ELSE
10785          DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10786       ENDIF
10787
10788       RETURN
10789       END
10790
10791 *$ CREATE DT_DENTST.FOR
10792 *COPY DT_DENTST
10793 *
10794 *===dentst=============================================================*
10795 *
10796 C      PROGRAM DT_DENTST
10797       SUBROUTINE DT_DENTST
10798
10799       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10800       SAVE
10801
10802       OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10803       OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10804
10805       RMIN  = 0.0D0
10806       RMAX  = 8.0D0
10807       NBINS = 500.0D0
10808       DR    = (RMAX-RMIN)/DBLE(NBINS)
10809       DO 1 IA=5,18
10810          FMAX = 0.0D0
10811          DO 2 IR=1,NBINS+1
10812             R = RMIN+DBLE(IR-1)*DR
10813             F = DT_DENSIT(IA,R,R)
10814             IF (F.GT.FMAX) FMAX = F
10815             WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10816     2    CONTINUE
10817          WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10818     1 CONTINUE
10819
10820       CLOSE(40)
10821       CLOSE(41)
10822
10823       END
10824
10825 *$ CREATE DT_SHMAKI.FOR
10826 *COPY DT_SHMAKI
10827 *
10828 *===shmaki=============================================================*
10829 *
10830       SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10831
10832 ************************************************************************
10833 * Initialisation of Glauber formalism. This subroutine has to be       *
10834 * called once (in case of target emulsions as often as many different  *
10835 * target nuclei are considered) before events are sampled.             *
10836 *         NA / NCA   mass number/charge of projectile nucleus          *
10837 *         NB / NCB   mass number/charge of target     nucleus          *
10838 *         IJP        identity of projectile (hadrons/leptons/photons)  *
10839 *         PPN        projectile momentum (for projectile nuclei:       *
10840 *                    momentum per nucleon) in target rest system       *
10841 *         MODE = 0   Glauber formalism invoked                         *
10842 *              = 1   fitted results are loaded from data-file          *
10843 *              = 99  NTARG is forced to be 1                           *
10844 *                    (used in connection with GLAUBERI-card only)      *
10845 * This version dated 22.03.96 is based on the original SHMAKI-routine  *
10846 * and revised by S. Roesler.                                           *
10847 ************************************************************************
10848
10849       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10850       SAVE
10851
10852       PARAMETER ( LINP = 10 ,
10853      &            LOUT = 6 ,
10854      &            LDAT = 9 )
10855
10856       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10857      &           THREE=3.0D0)
10858
10859       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10860
10861 * Glauber formalism: parameters
10862       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10863      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10864      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10865      &                NSITEB,NSTATB
10866
10867 * Lorentz-parameters of the current interaction
10868       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10869      &                UMO,PPCM,EPROJ,PPROJ
10870
10871 * properties of photon/lepton projectiles
10872       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10873
10874 * kinematical cuts for lepton-nucleus interactions
10875       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10876      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10877
10878 * Glauber formalism: cross sections
10879       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10880      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10881      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10882      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10883      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10884      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10885      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10886      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10887      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10888      &                BSLOPE,NEBINI,NQBINI
10889
10890 * cuts for variable energy runs
10891       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10892
10893 * nucleon-nucleon event-generator
10894       CHARACTER*8 CMODEL
10895       LOGICAL LPHOIN
10896       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10897
10898 * Glauber formalism: flags and parameters for statistics
10899       LOGICAL LPROD
10900       CHARACTER*8 CGLB
10901       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10902
10903       DATA NTARG,ICOUT,IVEOUT /0,0,0/
10904
10905 C     CALL DT_HISHAD
10906 C     STOP
10907
10908       NTARG = NTARG+1
10909       IF (MODE.EQ.99) NTARG = 1
10910       NIDX = -NTARG
10911       IF (MODE.EQ.-1) NIDX = NTARG
10912
10913       IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10914       IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10915  1000    FORMAT(//,1X,'SHMAKI:    Glauber formalism (Shmakov et. al) -',
10916      &          ' initialization',/,12X,'--------------------------',
10917      &          '-------------------------',/)
10918
10919       IF (MODE.EQ.2) THEN
10920          CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10921          CALL DT_SHFAST(MODE,PPN,IBACK)
10922          STOP ' Glauber pre-initialization done'
10923       ENDIF
10924       IF (MODE.EQ.1) THEN
10925          CALL DT_PROFBI(NA,NB,PPN,NTARG)
10926       ELSE
10927          IBACK = 1
10928          IF (MODE.EQ.3)  CALL DT_SHFAST(MODE,PPN,IBACK)
10929          IF (IBACK.EQ.1) THEN
10930 * lepton-nucleus (variable energy runs)
10931             IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10932      &          (IJP.EQ.10).OR.(IJP.EQ.11))   THEN
10933                IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10934      &            WRITE(LOUT,1002) NB,NCB
10935  1002          FORMAT(1X,'variable energy run:     projectile-id:  7',
10936      &                '    target A/Z: ',I3,' /',I3,/,/,8X,
10937      &                'E_cm (GeV)    Q^2 (GeV^2)',
10938      &                '    Sigma_tot (mb)     Sigma_in (mb)',/,7X,
10939      &                '--------------------------------',
10940      &                '------------------------------')
10941                AECMLO = LOG10(MIN(UMO,ECMLI))
10942                AECMHI = LOG10(MIN(UMO,ECMHI))
10943                IESTEP = NEB-1
10944                DAECM  = (AECMHI-AECMLO)/DBLE(IESTEP)
10945                IF (AECMLO.EQ.AECMHI) IESTEP = 0
10946                DO 1 I=1,IESTEP+1
10947                   ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10948                   IF (Q2HI.GT.0.1D0) THEN
10949                      IF (Q2LI.LT.0.01D0) THEN
10950                         CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10951                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10952      &                     WRITE(LOUT,1003)
10953      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10954                         Q2LI = 0.01D0
10955                         IBIN = 2
10956                      ELSE
10957                         IBIN = 1
10958                      ENDIF
10959                      IQSTEP = NQB-IBIN
10960                      AQ2LO  = LOG10(Q2LI)
10961                      AQ2HI  = LOG10(Q2HI)
10962                      DAQ2   = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10963                      DO 2 J=IBIN,IQSTEP+IBIN
10964                         Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10965                         CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10966                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10967      &                     WRITE(LOUT,1003) ECMNN(I),
10968      &                     Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10969     2                CONTINUE
10970                   ELSE
10971                      CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10972                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10973      &                  WRITE(LOUT,1003)
10974      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10975                   ENDIF
10976  1003             FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10977     1          CONTINUE
10978                IVEOUT = 1
10979             ELSE
10980 * hadron/photon/nucleus-nucleus
10981                IF ((ABS(VAREHI).GT.ZERO).AND.
10982      &             (ABS(VAREHI).GT.ABS(VARELO))) THEN
10983                   IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10984                      WRITE(LOUT,1004) NA,NB,NCB
10985  1004                FORMAT(1X,'variable energy run:    projectile-id:',
10986      &                      I3,'    target A/Z: ',I3,' /',I3,/)
10987                      WRITE(LOUT,1005)
10988  1005                FORMAT('  E_cm (GeV)  E_Lab (GeV)  sig_tot^pp (mb)'
10989      &                      ,'  Sigma_tot (mb)  Sigma_prod (mb)',/,
10990      &                      ' -------------------------------------',
10991      &                      '--------------------------------------')
10992                   ENDIF
10993                   AECMLO = LOG10(VARCLO)
10994                   AECMHI = LOG10(VARCHI)
10995                   IESTEP = NEB-1
10996                   DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10997                   IF (AECMLO.EQ.AECMHI) IESTEP = 0
10998                   DO 3 I=1,IESTEP+1
10999                      ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
11000                      AMP = 0.938D0
11001                      AMT = 0.938D0
11002                      AMP2 = AMP**2
11003                      AMT2 = AMT**2
11004                      ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
11005                      PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
11006                      CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
11007                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
11008      &                 WRITE(LOUT,1006)
11009      &                 ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
11010  1006             FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
11011     3             CONTINUE
11012                   IVEOUT = 1
11013                ELSE
11014                   CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
11015                ENDIF
11016             ENDIF
11017          ENDIF
11018       ENDIF
11019
11020       IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
11021      &    (IOGLB.NE.100)) THEN
11022          WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
11023      &                    BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
11024  1001    FORMAT(38X,'projectile',
11025      &          '      target',/,1X,'Mass number / charge',
11026      &          17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
11027      &          'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
11028      &          'Parameters of elastic scattering amplitude:',/,5X,
11029      &          'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
11030      &          F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
11031      &          'statistics at each b-step',4X,I5,/,/,1X,
11032      &          'Prod. cross section  ',5X,F10.4,' mb',/)
11033       ENDIF
11034
11035       RETURN
11036       END
11037
11038 *$ CREATE DT_PROFBI.FOR
11039 *COPY DT_PROFBI
11040 *
11041 *===profbi=============================================================*
11042 *
11043       SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
11044
11045 ************************************************************************
11046 * Integral over profile function (to be used for impact-parameter      *
11047 * sampling during event generation).                                   *
11048 * Fitted results are used.                                             *
11049 *         NA / NB    mass numbers of proj./target nuclei               *
11050 *         PPN        projectile momentum (for projectile nuclei:       *
11051 *                    momentum per nucleon) in target rest system       *
11052 *         NTARG      index of target material (i.e. kind of nucleus)   *
11053 * This version dated 31.05.95 is revised by S. Roesler                 *
11054 ************************************************************************
11055
11056       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11057       SAVE
11058
11059       PARAMETER ( LINP = 10 ,
11060      &            LOUT = 6 ,
11061      &            LDAT = 9 )
11062
11063       SAVE
11064
11065       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
11066
11067       LOGICAL LSTART
11068       CHARACTER CNAME*80
11069
11070       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11071
11072 * Glauber formalism: parameters
11073       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11074      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11075      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11076      &                NSITEB,NSTATB
11077
11078 * Glauber formalism: cross sections
11079       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11080      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11081      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11082      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11083      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11084      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11085      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11086      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11087      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11088      &                BSLOPE,NEBINI,NQBINI
11089
11090       PARAMETER (NGLMAX=8000)
11091       DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
11092      &          GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
11093
11094       DATA LSTART /.TRUE./
11095
11096       IF (LSTART) THEN
11097 * read fit-parameters from file
11098          OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
11099          I = 0
11100     1    CONTINUE
11101          READ(47,'(A80)') CNAME
11102          IF (CNAME.EQ.'STOP') GOTO 2
11103          I = I+1
11104          READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
11105      &                 GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
11106      &                 GLAFIT(4,I),GLAFIT(5,I)
11107          IF (I+1.GT.NGLMAX) THEN
11108             WRITE(LOUT,1000)
11109  1000       FORMAT(1X,'PROFBI:    warning! array size exceeded - ',
11110      &             'program stopped')
11111             STOP
11112          ENDIF
11113          GOTO 1
11114     2    CONTINUE
11115          NGLPAR = I
11116          LSTART = .FALSE.
11117       ENDIF
11118
11119       NNA = NA
11120       NNB = NB
11121       IF (NA.GT.NB) THEN
11122          NNA = NB
11123          NNB = NA
11124       ENDIF
11125       IDXGLA = 0
11126       DO 3 J=1,NGLPAR
11127          IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
11128             IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
11129             DO 4 K=1,J-1
11130                IPOINT = J-K
11131                IF (J.EQ.NGLPAR) IPOINT = J+1-K
11132                IF ((NNA.GT.NGLIP(IPOINT)).OR.
11133      &             (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
11134                   IF (IPOINT.EQ.1) IPOINT = 0
11135                   NATMP = NGLIP(IPOINT+1)
11136                   IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
11137                      IDXGLA = IPOINT+1
11138                      GOTO 6
11139                   ELSE
11140                      J1BEG = IPOINT+1
11141                      J1END = J
11142 C                    IF (J.EQ.NGLPAR) THEN
11143 C                       J1BEG = IPOINT
11144 C                       J1END = J
11145 C                    ENDIF
11146                      DO 5 J1=J1BEG,J1END
11147                         IF (NGLIP(J1).EQ.NATMP) THEN
11148                            IF (PPN.LT.GLAPPN(J1)) THEN
11149                               IDXGLA = J1
11150                               GOTO 6
11151                            ENDIF
11152                         ELSE
11153                            IDXGLA = J1-1
11154                            GOTO 6
11155                         ENDIF
11156     5                CONTINUE
11157                      IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
11158      &                  IDXGLA = NGLPAR
11159                   ENDIF
11160                ENDIF
11161     4       CONTINUE
11162          ENDIF
11163     3 CONTINUE
11164
11165     6 CONTINUE
11166       IF (IDXGLA.EQ.0) THEN
11167          WRITE(LOUT,1001) NNA,NNB,PPN
11168  1001    FORMAT(1X,'PROFBI:   configuration (NA,NB,PPN = ',
11169      &          2I4,F6.0,') not found ')
11170          STOP
11171       ENDIF
11172
11173 * no interpolation yet available
11174       XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
11175
11176       BSITE(1,1,NTARG,1) = ZERO
11177       DO 10 I=2,NSITEB
11178          XX = DBLE(I)
11179          POLY  = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
11180      &           GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
11181      &           GLAFIT(5,IDXGLA)*XX**4
11182          IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
11183          BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
11184          IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
11185    10 CONTINUE
11186
11187       RETURN
11188       END
11189
11190 *$ CREATE DT_GLAUBE.FOR
11191 *COPY DT_GLAUBE
11192 *
11193 *===glaube=============================================================*
11194 *
11195       SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
11196
11197 ************************************************************************
11198 * Calculation of configuartion of interacting nucleons for one event.  *
11199 *    NB / NB    mass numbers of proj./target nuclei           (input)  *
11200 *    B          impact parameter                              (output) *
11201 *    INTT       total number of wounded nucleons                 "     *
11202 *    INTA / INTB number of wounded nucleons in proj. / target    "     *
11203 *    JS / JT(i) number of collisions proj. / target nucleon i is       *
11204 *                                                   involved  (output) *
11205 *    NIDX       index of projectile/target material            (input) *
11206 *               = -2 call within FLUKA transport calculation           *
11207 * This is an update of the original routine SHMAKO by J.Ranft/HJM      *
11208 * This version dated 22.03.96 is revised by S. Roesler                 *
11209 *                                                                      *
11210 * Last change 27.12.2006 by S. Roesler.                                *
11211 ************************************************************************
11212
11213       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11214       SAVE
11215
11216       PARAMETER ( LINP = 10 ,
11217      &            LOUT = 6 ,
11218      &            LDAT = 9 )
11219
11220       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
11221      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
11222
11223       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11224
11225       PARAMETER ( MAXNCL = 260,
11226
11227      &            MAXVQU = MAXNCL,
11228      &            MAXSQU = 20*MAXVQU,
11229      &            MAXINT = MAXVQU+MAXSQU)
11230
11231 * Glauber formalism: parameters
11232       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11233      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11234      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11235      &                NSITEB,NSTATB
11236
11237 * Glauber formalism: cross sections
11238       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11239      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11240      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11241      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11242      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11243      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11244      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11245      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11246      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11247      &                BSLOPE,NEBINI,NQBINI
11248
11249 * Lorentz-parameters of the current interaction
11250       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
11251      &                UMO,PPCM,EPROJ,PPROJ
11252
11253 * properties of photon/lepton projectiles
11254       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
11255
11256 * Glauber formalism: collision properties
11257       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
11258      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
11259
11260 * Glauber formalism: flags and parameters for statistics
11261       LOGICAL LPROD
11262       CHARACTER*8 CGLB
11263       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11264
11265       DIMENSION JS(MAXNCL),JT(MAXNCL)
11266
11267       NTARG = ABS(NIDX)
11268
11269 * get actual energy from /DTLTRA/
11270       ECMNOW = UMO
11271       Q2     = VIRT
11272 *
11273 * new patch for pre-initialized variable projectile/target/energy runs,
11274 * bypassed for use within FLUKA (Nidx=-2)
11275       IF (IOGLB.EQ.100) THEN
11276          IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
11277 *
11278 * variable energy run, interpolate profile function
11279       ELSE
11280          I1   = 1
11281          I2   = 1
11282          RATE = ONE
11283          IF (NEBINI.GT.1) THEN
11284             IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
11285                I1   = NEBINI
11286                I2   = NEBINI
11287                RATE = ONE
11288             ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
11289                DO 1 I=2,NEBINI
11290                   IF (ECMNOW.LT.ECMNN(I)) THEN
11291                      I1   = I-1
11292                      I2   = I
11293                      RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
11294                      GOTO 2
11295                   ENDIF
11296     1          CONTINUE
11297     2          CONTINUE
11298             ENDIF
11299          ENDIF
11300          J1   = 1
11301          J2   = 1
11302          RATQ = ONE
11303          IF (NQBINI.GT.1) THEN
11304             IF (Q2.GE.Q2G(NQBINI)) THEN
11305                J1   = NQBINI
11306                J2   = NQBINI
11307                RATQ = ONE
11308             ELSEIF (Q2.GT.Q2G(1)) THEN
11309                DO 3 I=2,NQBINI
11310                   IF (Q2.LT.Q2G(I)) THEN
11311                      J1   = I-1
11312                      J2   = I
11313                      RATQ = LOG10(     Q2/MAX(Q2G(J1),TINY14))/
11314      &                      LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11315 C                    RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
11316                      GOTO 4
11317                   ENDIF
11318     3          CONTINUE
11319     4          CONTINUE
11320             ENDIF
11321          ENDIF
11322
11323          DO 5 I=1,KSITEB
11324             BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
11325      &         RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11326      &         RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11327      &         RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
11328      &                    BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
11329     5    CONTINUE
11330       ENDIF
11331
11332       CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
11333       IF (NIDX.LE.-1) THEN
11334          RPROJ = RASH(1)
11335          RTARG = RBSH(NTARG)
11336       ELSE
11337          RPROJ = RASH(NTARG)
11338          RTARG = RBSH(1)
11339       ENDIF
11340
11341       RETURN
11342       END
11343
11344 *$ CREATE DT_DIAGR.FOR
11345 *COPY DT_DIAGR
11346 *
11347 *===diagr==============================================================*
11348 *
11349       SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
11350      &                                                         NIDX)
11351
11352 ************************************************************************
11353 * Based on the original version by Shmakov et al.                      *
11354 * This version dated 21.04.95 is revised by S. Roesler                 *
11355 ************************************************************************
11356
11357       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11358       SAVE
11359
11360       PARAMETER ( LINP = 10 ,
11361      &            LOUT = 6 ,
11362      &            LDAT = 9 )
11363
11364       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
11365       PARAMETER (TWOPI  = 6.283185307179586454D+00,
11366      &           PI     = TWOPI/TWO,
11367      &           GEV2MB = 0.38938D0,
11368      &           GEV2FM = 0.1972D0,
11369      &           ALPHEM = ONE/137.0D0,
11370 * proton mass
11371      &           AMP    = 0.938D0,
11372      &           AMP2   = AMP**2,
11373 * rho0 mass
11374      &           AMRHO0 = 0.77D0)
11375
11376       COMPLEX*16 C,CA,CI
11377
11378       PARAMETER ( MAXNCL = 260,
11379
11380      &            MAXVQU = MAXNCL,
11381      &            MAXSQU = 20*MAXVQU,
11382      &            MAXINT = MAXVQU+MAXSQU)
11383
11384 * particle properties (BAMJET index convention)
11385       CHARACTER*8  ANAME
11386       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11387      &                IICH(210),IIBAR(210),K1(210),K2(210)
11388
11389       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11390
11391 * emulsion treatment
11392       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11393      &                NCOMPO,IEMUL
11394
11395 * Glauber formalism: parameters
11396       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11397      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11398      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11399      &                NSITEB,NSTATB
11400
11401 * Glauber formalism: cross sections
11402       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11403      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11404      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11405      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11406      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11407      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11408      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11409      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11410      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11411      &                BSLOPE,NEBINI,NQBINI
11412
11413 * VDM parameter for photon-nucleus interactions
11414       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11415
11416 * nucleon-nucleon event-generator
11417       CHARACTER*8 CMODEL
11418       LOGICAL LPHOIN
11419       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
11420 **PHOJET105a
11421 C     COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11422 **PHOJET112
11423
11424 C  obsolete cut-off information
11425       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
11426       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11427 **
11428
11429 * coordinates of nucleons
11430       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
11431
11432 * interface between Glauber formalism and DPM
11433       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
11434      &                INTER1(MAXINT),INTER2(MAXINT)
11435
11436 * statistics: Glauber-formalism
11437       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
11438
11439 * n-n cross section fluctuations
11440       PARAMETER (NBINS = 1000)
11441       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
11442
11443       DIMENSION JS(MAXNCL),JT(MAXNCL),
11444      &          JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
11445      &          JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
11446       DIMENSION NWA(0:210),NWB(0:210)
11447
11448       LOGICAL LFIRST
11449       DATA LFIRST /.TRUE./
11450
11451       DATA NTARGO,ICNT /0,0/
11452
11453       NTARG = ABS(NIDX)
11454
11455       IF (LFIRST) THEN
11456          LFIRST = .FALSE.
11457          IF (NCOMPO.EQ.0) THEN
11458             NCALL  = 0
11459             NWAMAX = NA
11460             NWBMAX = NB
11461             DO 17 I=0,210
11462                NWA(I) = 0
11463                NWB(I) = 0
11464    17       CONTINUE
11465          ENDIF
11466       ENDIF
11467       IF (NTARG.EQ.-1) THEN
11468          IF (NCOMPO.EQ.0) THEN
11469             WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
11470             WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
11471      &                                NCALL,NWAMAX,NWBMAX
11472             DO 18 I=1,MAX(NWAMAX,NWBMAX)
11473                WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
11474      &                          I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
11475      &                            NWB(I),DBLE(NWB(I))/DBLE(NCALL)
11476    18       CONTINUE
11477          ENDIF
11478          RETURN
11479       ENDIF
11480
11481       DCOH   = 1.0D10
11482       IPNT   = 0
11483
11484       SQ2  = Q2
11485       IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
11486       S   = ECMNOW**2
11487       X   = SQ2/(S+SQ2-AMP2)
11488       XNU = (S+SQ2-AMP2)/(TWO*AMP)
11489 * photon projectiles: recalculate photon-nucleon amplitude
11490       IF (IJPROJ.EQ.7) THEN
11491    15    CONTINUE
11492 *  VDM assumption: mass of V-meson
11493          AMV2   = DT_SAM2(SQ2,ECMNOW)
11494          AMV    = SQRT(AMV2)
11495          IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
11496 *  check for pointlike interaction
11497          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
11498 **sr 27.10.
11499 C        SIGSH  = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11500          SIGSH  = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11501 **
11502          ROSH   = 0.1D0
11503          BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
11504      &                   +0.25D0*LOG(S/(AMV2+SQ2)))
11505 *  coherence length
11506          IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
11507       ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
11508          IF (MCGENE.EQ.2) THEN
11509             ZERO1 = ZERO
11510             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
11511      &                                                BSLOPE,0)
11512          ELSE
11513             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
11514          ENDIF
11515          IF (ECMNOW.LE.3.0D0) THEN
11516             ROSH = -0.43D0
11517          ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
11518             ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
11519          ELSEIF (ECMNOW.GT.50.0D0) THEN
11520             ROSH = 0.1D0
11521          ENDIF
11522          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11523          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11524          IF (MCGENE.EQ.2) THEN
11525             ZERO1 = ZERO
11526             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
11527      &                                                  BDUM,0)
11528             SIGSH = SIGSH/10.0D0
11529          ELSE
11530 C           SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11531             DUMZER = ZERO
11532             CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11533             SIGSH = SIGSH/10.0D0
11534          ENDIF
11535       ELSE
11536          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
11537          ROSH   = 0.01D0
11538          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11539          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11540 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11541          DUMZER = ZERO
11542          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11543          SIGSH = SIGSH/10.0D0
11544       ENDIF
11545       GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
11546       GAM = GSH
11547       RCA = GAM*SIGSH/TWOPI
11548       FCA = -ROSH*RCA
11549       CA  = DCMPLX(RCA,FCA)
11550       CI  = DCMPLX(ONE,ZERO)
11551
11552    16 CONTINUE
11553 * impact parameter
11554       IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11555
11556       NTRY = 0
11557     3 CONTINUE
11558       NTRY = NTRY+1
11559 * initializations
11560       JNT  = 0
11561       DO 1 I=1,NA
11562          JS(I) = 0
11563     1 CONTINUE
11564       DO 2 I=1,NB
11565          JT(I) = 0
11566     2 CONTINUE
11567       IF (IJPROJ.EQ.7) THEN
11568          DO 8 I=1,MAXNCL
11569             JS0(I) = 0
11570             JNT0(I)= 0
11571             DO 9 J=1,NB
11572                JT0(I,J) = 0
11573     9       CONTINUE
11574     8    CONTINUE
11575       ENDIF
11576
11577 * nucleon configuration
11578 C     IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11579       IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11580 C        CALL DT_CONUCL(PKOO,NA,RASH,2)
11581 C        CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11582          IF (NIDX.LE.-1) THEN
11583             CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11584             CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11585          ELSE
11586             CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11587             CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11588          ENDIF
11589          NTARGO = NTARG
11590       ENDIF
11591       ICNT = ICNT+1
11592
11593 * LEPTO: pick out one struck nucleon
11594       IF (MCGENE.EQ.3) THEN
11595          JNT     = 1
11596          JS(1)   = 1
11597          IDX     = INT(DT_RNDM(X)*NB)+1
11598          JT(IDX) = 1
11599          B       = ZERO
11600          GOTO 19
11601       ENDIF
11602
11603       DO 4 INA=1,NA
11604 * cross section fluctuations
11605          AFLUC = ONE
11606          IF (IFLUCT.EQ.1) THEN
11607             IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11608             AFLUC = FLUIXX(IFLUK)
11609          ENDIF
11610          KK1  = 1
11611          KINT = 1
11612          DO 5 INB=1,NB
11613 * photon-projectile: check for supression by coherence length
11614             IF (IJPROJ.EQ.7) THEN
11615                IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11616                   KK1  = INB
11617                   KINT = KINT+1
11618                ENDIF
11619             ENDIF
11620             QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11621             QQ2 =   TKOO(2,INB)-PKOO(2,INA)
11622             XY  = GAM*(QQ1*QQ1+QQ2*QQ2)
11623             IF (XY.LE.15.0D0) THEN
11624                C  = CI-CA*AFLUC*EXP(-XY)
11625                AR = DBLE(C)
11626                AI = DIMAG(C)
11627                P  = AR*AR+AI*AI
11628                IF (DT_RNDM(XY).GE.P) THEN
11629                   JNT = JNT+1
11630                   IF (IJPROJ.EQ.7) THEN
11631                      JNT0(KINT) = JNT0(KINT)+1
11632                      IF (JNT0(KINT).GT.MAXNCL) THEN
11633                         WRITE(LOUT,1001) MAXNCL
11634  1001                   FORMAT(1X,
11635      &                        'DIAGR:  no. of requested interactions',
11636      &                        ' exceeds array dimensions ',I4)
11637                         STOP
11638                      ENDIF
11639                      JS0(KINT)      = JS0(KINT)+1
11640                      JT0(KINT,INB)  = JT0(KINT,INB)+1
11641                      JI1(KINT,JNT0(KINT)) = INA
11642                      JI2(KINT,JNT0(KINT)) = INB
11643                   ELSE
11644                      IF (JNT.GT.MAXINT) THEN
11645                         WRITE(LOUT,1000) JNT, MAXINT
11646  1000                   FORMAT(1X,
11647      &                        'DIAGR:  no. of requested interactions ('
11648      &                        ,I4,') exceeds array dimensions (',I4,')')
11649                         STOP
11650                      ENDIF
11651                      JS(INA) = JS(INA)+1
11652                      JT(INB) = JT(INB)+1
11653                      INTER1(JNT) = INA
11654                      INTER2(JNT) = INB
11655                   ENDIF
11656                ENDIF
11657             ENDIF
11658     5    CONTINUE
11659     4 CONTINUE
11660
11661       IF (JNT.EQ.0) THEN
11662          IF (NTRY.LT.500) THEN
11663             GOTO 3
11664          ELSE
11665 C           WRITE(6,*) ' new impact parameter required (old= ',B,')'
11666             GOTO 16
11667          ENDIF
11668       ENDIF
11669
11670       IDIREC = 0
11671       IF (IJPROJ.EQ.7) THEN
11672          K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11673    10    CONTINUE
11674          IF (JNT0(K).EQ.0) THEN
11675             K = K+1
11676             IF (K.GT.KINT) K = 1
11677             GOTO 10
11678          ENDIF
11679 * supress Glauber-cascade by direct photon processes
11680          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11681          IF (IPNT.GT.0) THEN
11682             JNT   = 1
11683             JS(1) = 1
11684             DO 11 INB=1,NB
11685                JT(INB) = JT0(K,INB)
11686                IF (JT(INB).GT.0) GOTO 12
11687    11       CONTINUE
11688    12       CONTINUE
11689             INTER1(1) = 1
11690             INTER2(1) = INB
11691             IDIREC    = IPNT
11692          ELSE
11693             JNT   = JNT0(K)
11694             JS(1) = JS0(K)
11695             DO 13 INB=1,NB
11696                JT(INB) = JT0(K,INB)
11697    13       CONTINUE
11698             DO 14 I=1,JNT
11699                INTER1(I) = JI1(K,I)
11700                INTER2(I) = JI2(K,I)
11701    14       CONTINUE
11702          ENDIF
11703       ENDIF
11704
11705    19 CONTINUE
11706       INTA = 0
11707       INTB = 0
11708       DO 6 I=1,NA
11709         IF (JS(I).NE.0) INTA=INTA+1
11710     6 CONTINUE
11711       DO 7 I=1,NB
11712         IF (JT(I).NE.0) INTB=INTB+1
11713     7 CONTINUE
11714       ICWPG = INTA
11715       ICWTG = INTB
11716       ICIG  = JNT
11717       IPGLB = IPGLB+INTA
11718       ITGLB = ITGLB+INTB
11719       NGLB = NGLB+1
11720
11721       IF (NCOMPO.EQ.0) THEN
11722          NCALL = NCALL+1
11723          NWA(INTA) = NWA(INTA)+1
11724          NWB(INTB) = NWB(INTB)+1
11725       ENDIF
11726
11727       RETURN
11728       END
11729
11730 *$ CREATE DT_MODB.FOR
11731 *COPY DT_MODB
11732 *
11733 *===modb===============================================================*
11734 *
11735       SUBROUTINE DT_MODB(B,NIDX)
11736
11737 ************************************************************************
11738 * Sampling of impact parameter of collision.                           *
11739 *    B          impact parameter    (output)                           *
11740 *    NIDX       index of projectile/target material             (input)*
11741 * Based on the original version by Shmakov et al.                      *
11742 * This version dated 21.04.95 is revised by S. Roesler                 *
11743 *                                                                      *
11744 * Last change 27.12.2006 by S. Roesler.                                *
11745 ************************************************************************
11746
11747       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11748       SAVE
11749
11750       PARAMETER ( LINP = 10 ,
11751      &            LOUT = 6 ,
11752      &            LDAT = 9 )
11753
11754       PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11755
11756       LOGICAL LEFT,LFIRST
11757
11758 * central particle production, impact parameter biasing
11759       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11760
11761       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11762
11763 * Glauber formalism: parameters
11764       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11765      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11766      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11767      &                NSITEB,NSTATB
11768
11769 * Glauber formalism: cross sections
11770       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11771      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11772      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11773      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11774      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11775      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11776      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11777      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11778      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11779      &                BSLOPE,NEBINI,NQBINI
11780
11781       DATA LFIRST /.TRUE./
11782
11783       NTARG = ABS(NIDX)
11784       IF (NIDX.LE.-1) THEN
11785          RA = RASH(1)
11786          RB = RBSH(NTARG)
11787       ELSE
11788          RA = RASH(NTARG)
11789          RB = RBSH(1)
11790       ENDIF
11791
11792       IF (ICENTR.EQ.2) THEN
11793          IF (RA.EQ.RB) THEN
11794             BB = DT_RNDM(B)*(0.3D0*RA)**2
11795             B  = SQRT(BB)
11796          ELSEIF(RA.LT.RB)THEN
11797             BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11798             B  = SQRT(BB)
11799          ELSEIF(RA.GT.RB)THEN
11800             BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11801             B  = SQRT(BB)
11802          ENDIF
11803       ELSE
11804     9    CONTINUE
11805          Y  = DT_RNDM(BB)
11806          I0 = 1
11807          I2 = NSITEB
11808    10    CONTINUE
11809          I1 = (I0+I2)/2
11810          LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11811      &          *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11812          IF (LEFT) GOTO 20
11813          I0 = I1
11814          GOTO 30
11815    20    CONTINUE
11816          I2 = I1
11817    30    CONTINUE
11818          IF (I2-I0-2) 40,50,60
11819    40    CONTINUE
11820          I1 = I2+1
11821          IF (I1.GT.NSITEB) I1 = I0-1
11822          GOTO 70
11823    50    CONTINUE
11824          I1 = I0+1
11825          GOTO 70
11826    60    CONTINUE
11827          GOTO 10
11828    70    CONTINUE
11829          X0 = DBLE(I0-1)*BSTEP(NTARG)
11830          X1 = DBLE(I1-1)*BSTEP(NTARG)
11831          X2 = DBLE(I2-1)*BSTEP(NTARG)
11832          Y0 = BSITE(0,1,NTARG,I0)
11833          Y1 = BSITE(0,1,NTARG,I1)
11834          Y2 = BSITE(0,1,NTARG,I2)
11835    80    CONTINUE
11836          B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11837      &       X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11838      &       X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11839 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11840          B = B+0.5D0*BSTEP(NTARG)
11841          IF (B.LT.ZERO) B = X1
11842          IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11843          IF (ICENTR.LT.0) THEN
11844             IF (LFIRST) THEN
11845                LFIRST = .FALSE.
11846                IF (ICENTR.LE.-100) THEN
11847                   BIMIN  = 0.0D0
11848                ELSE
11849                   XSFRAC = 0.0D0
11850                ENDIF
11851                CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11852                WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11853      &                          BIMIN,BIMAX,XSFRAC*100.0D0,
11854      &                          XSFRAC*XSPRO(1,1,NTARG)
11855  10000         FORMAT(/,1X,'DT_MODB:      Biasing in impact parameter',
11856      &                /,15X,'---------------------------'/,/,4X,
11857      &                'average radii of proj / targ :',F10.3,' fm /',
11858      &                F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11859      &                F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11860      &                F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11861      &                ' cross section :',F10.3,' %',/,5X,
11862      &                'corresponding cross section :',F10.3,' mb',/)
11863             ENDIF
11864             IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11865                B = BIMIN
11866             ELSE
11867                IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11868             ENDIF
11869          ENDIF
11870       ENDIF
11871
11872       RETURN
11873       END
11874
11875 *$ CREATE DT_SHFAST.FOR
11876 *COPY DT_SHFAST
11877 *
11878 *===shfast=============================================================*
11879 *
11880       SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11881
11882       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11883       SAVE
11884
11885       PARAMETER ( LINP = 10 ,
11886      &            LOUT = 6 ,
11887      &            LDAT = 9 )
11888
11889       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11890      &           ONE=1.0D0,TWO=2.0D0)
11891
11892       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11893
11894 * Glauber formalism: parameters
11895       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11896      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11897      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11898      &                NSITEB,NSTATB
11899
11900 * properties of interacting particles
11901       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11902
11903 * Glauber formalism: cross sections
11904       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11905      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11906      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11907      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11908      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11909      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11910      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11911      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11912      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11913      &                BSLOPE,NEBINI,NQBINI
11914
11915       IBACK = 0
11916
11917       IF (MODE.EQ.2) THEN
11918          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11919          WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11920  1000    FORMAT(1X,8I5,E15.5)
11921          WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11922  1001    FORMAT(1X,4E15.5)
11923          WRITE(47,1002) SIGSH,ROSH,GSH
11924  1002    FORMAT(1X,3E15.5)
11925          DO 10 I=1,100
11926             WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11927    10    CONTINUE
11928          WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11929  1003    FORMAT(1X,2I10,3E15.5)
11930          CLOSE(47)
11931       ELSE
11932          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11933          READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11934          IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11935      &       (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11936      &       .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11937      &       (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11938             READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11939             READ(47,1002) SIGSH,ROSH,GSH
11940             DO 11 I=1,100
11941                READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11942    11       CONTINUE
11943             READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11944          ELSE
11945             IBACK = 1
11946          ENDIF
11947          CLOSE(47)
11948       ENDIF
11949
11950       RETURN
11951       END
11952
11953 *$ CREATE DT_POILIK.FOR
11954 *COPY DT_POILIK
11955 *
11956 *===poilik=============================================================*
11957 *
11958       SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11959
11960       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11961       SAVE
11962
11963       PARAMETER ( LINP = 10 ,
11964      &            LOUT = 6 ,
11965      &            LDAT = 9 )
11966
11967       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11968       PARAMETER (NE = 8)
11969
11970 **PHOJET105a
11971 C     CHARACTER*8 MDLNA
11972 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11973 C     PARAMETER (IEETAB=10)
11974 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11975 **PHOJET110
11976
11977 C  model switches and parameters
11978       CHARACTER*8 MDLNA
11979       INTEGER ISWMDL,IPAMDL
11980       DOUBLE PRECISION PARMDL
11981       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11982
11983 C  energy-interpolation table
11984       INTEGER IEETA2
11985       PARAMETER ( IEETA2 = 20 )
11986       INTEGER ISIMAX
11987       DOUBLE PRECISION SIGTAB,SIGECM
11988       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11989 **
11990
11991 * VDM parameter for photon-nucleus interactions
11992       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11993 **sr 22.7.97
11994
11995       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11996
11997 * Glauber formalism: cross sections
11998       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11999      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
12000      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
12001      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
12002      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
12003      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12004      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12005      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12006      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12007      &                BSLOPE,NEBINI,NQBINI
12008 **
12009
12010       DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
12011
12012       IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
12013
12014 * load cross sections from interpolation table
12015       IP = 1
12016       IF(ECM.LE.SIGECM(IP,1)) THEN
12017         I1 = 1
12018         I2 = 1
12019       ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
12020         DO 50 I=2,ISIMAX
12021           IF(ECM.LE.SIGECM(IP,I)) GOTO 200
12022   50    CONTINUE
12023  200    CONTINUE
12024         I1 = I-1
12025         I2 = I
12026       ELSE
12027         WRITE(LOUT,'(/1X,A,2E12.3)')
12028      &    'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
12029         I1 = ISIMAX
12030         I2 = ISIMAX
12031       ENDIF
12032       FAC2 = ZERO
12033       IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
12034      &                     /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
12035       FAC1 = ONE-FAC2
12036
12037       SIGANO = DT_SANO(ECM)
12038
12039 * cross section dependence on photon virtuality
12040       FSUP1 = ZERO
12041       DO  150 I=1,3
12042          FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
12043      &                             /(ONE+VIRT/PARMDL(30+I))**2
12044  150  CONTINUE
12045       FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
12046       FAC1  = FAC1*FSUP1
12047       FAC2  = FAC2*FSUP1
12048       FSUP2 = ONE
12049
12050       ECMOLD = ECM
12051       Q2OLD  = VIRT
12052
12053     3 CONTINUE
12054
12055 C     SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
12056       CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
12057       IF (ISHAD(1).EQ.1) THEN
12058          SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
12059       ELSE
12060          SIGDIR = ZERO
12061       ENDIF
12062       SIGANO = FSUP1*FSUP2*SIGANO
12063       SIGTOT = SIGTOT-SIGDIR-SIGANO
12064       SIGDIR = SIGDIR/(FSUP1*FSUP2)
12065       SIGANO = SIGANO/(FSUP1*FSUP2)
12066       SIGTOT = SIGTOT+SIGDIR+SIGANO
12067
12068       RR = DT_RNDM(SIGTOT)
12069       IF (RR.LT.SIGDIR/SIGTOT) THEN
12070          IPNT = 1
12071       ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
12072      &        (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
12073          IPNT = 2
12074       ELSE
12075          IPNT = 0
12076       ENDIF
12077       RPNT = (SIGDIR+SIGANO)/SIGTOT
12078 C     WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
12079 C     WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
12080 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
12081 C     WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
12082       IF (MODE.EQ.1) RETURN
12083
12084 **sr 22.7.97
12085       K1   = 1
12086       K2   = 1
12087       RATE = ZERO
12088       IF (ECM.GE.ECMNN(NEBINI)) THEN
12089          K1   = NEBINI
12090          K2   = NEBINI
12091          RATE = ONE
12092       ELSEIF (ECM.GT.ECMNN(1)) THEN
12093          DO 10 I=2,NEBINI
12094             IF (ECM.LT.ECMNN(I)) THEN
12095                K1   = I-1
12096                K2   = I
12097                RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
12098                GOTO 11
12099             ENDIF
12100    10    CONTINUE
12101    11    CONTINUE
12102       ENDIF
12103       J1   = 1
12104       J2   = 1
12105       RATQ = ZERO
12106       IF (NQBINI.GT.1) THEN
12107          IF (VIRT.GE.Q2G(NQBINI)) THEN
12108             J1   = NQBINI
12109             J2   = NQBINI
12110             RATQ = ONE
12111          ELSEIF (VIRT.GT.Q2G(1)) THEN
12112             DO 12 I=2,NQBINI
12113                IF (VIRT.LT.Q2G(I)) THEN
12114                   J1   = I-1
12115                   J2   = I
12116                   RATQ = LOG10(   VIRT/MAX(Q2G(J1),TINY14))/
12117      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
12118                   GOTO 13
12119                ENDIF
12120    12       CONTINUE
12121    13       CONTINUE
12122          ENDIF
12123       ENDIF
12124       SGA = XSPRO(K1,J1,NTARG)+
12125      &      RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
12126      &      RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
12127      &      RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
12128      &                 XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
12129       SDI = DBLE(NB)*SIGDIR
12130       SAN = DBLE(NB)*SIGANO
12131       SPL = SDI+SAN
12132       RR = DT_RNDM(SPL)
12133       IF (RR.LT.SDI/SGA) THEN
12134          IPNT = 1
12135       ELSEIF ((RR.GE.SDI/SGA).AND.
12136      &        (RR.LT.SPL/SGA)) THEN
12137          IPNT = 2
12138       ELSE
12139          IPNT = 0
12140       ENDIF
12141       RPNT = SPL/SGA
12142 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
12143 **
12144
12145       RETURN
12146       END
12147
12148 *$ CREATE DT_GLBINI.FOR
12149 *COPY DT_GLBINI
12150 *
12151 *===glbini=============================================================*
12152 *
12153       SUBROUTINE DT_GLBINI(WHAT)
12154
12155 ************************************************************************
12156 * Pre-initialization of profile function                               *
12157 * This version dated 28.11.00 is written by S. Roesler.                *
12158 *                                                                      *
12159 * Last change 27.12.2006 by S. Roesler.                                *
12160 ************************************************************************
12161
12162       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12163       SAVE
12164
12165       PARAMETER ( LINP = 10 ,
12166      &            LOUT = 6 ,
12167      &            LDAT = 9 )
12168
12169       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
12170
12171       LOGICAL LCMS
12172
12173 * particle properties (BAMJET index convention)
12174       CHARACTER*8  ANAME
12175       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12176      &                IICH(210),IIBAR(210),K1(210),K2(210)
12177
12178 * properties of interacting particles
12179       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12180
12181       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12182
12183 * emulsion treatment
12184       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12185      &                NCOMPO,IEMUL
12186
12187 * Glauber formalism: flags and parameters for statistics
12188       LOGICAL LPROD
12189       CHARACTER*8 CGLB
12190       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12191
12192 * number of data sets other than protons and nuclei
12193 * at the moment = 2 (pions and kaons)
12194       PARAMETER (MAXOFF=2)
12195       DIMENSION IJPINI(5),IOFFST(25)
12196       DATA IJPINI / 13, 15,  0,  0,  0/
12197 * Glauber data-set to be used for hadron projectiles
12198 * (0=proton, 1=pion, 2=kaon)
12199       DATA (IOFFST(K),K=1,25) /
12200      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12201      &  0, 0, 1, 2, 2/
12202 * Acceptance interval for target nucleus mass
12203       PARAMETER (KBACC = 6)
12204
12205 * flags for input different options
12206       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12207       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12208      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12209
12210       PARAMETER (MAXMSS = 100)
12211       DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
12212       DIMENSION WHAT(6)
12213
12214       DATA JPEACH,JPSTEP / 18, 5 /
12215
12216 * temporary patch until fix has been implemented in phojet:
12217 *  maximum energy for pion projectile
12218       DATA ECMXPI / 100000.0D0 /
12219 *
12220 *--------------------------------------------------------------------------
12221 * general initializations
12222 *
12223 *  steps in projectile mass number for initialization
12224       IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
12225       IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
12226 *
12227 *  energy range and binning
12228       ELO  = ABS(WHAT(1))
12229       EHI  = ABS(WHAT(2))
12230       IF (ELO.GT.EHI) ELO = EHI
12231       NEBIN = MAX(INT(WHAT(3)),1)
12232       IF (ELO.EQ.EHI) NEBIN = 0
12233       LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
12234       IF (LCMS) THEN
12235          ECMINI = EHI
12236       ELSE
12237          ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
12238      &                 +2.0D0*AAM(IJTARG)*EHI)
12239       ENDIF
12240 *
12241 *  default arguments for Glauber-routine
12242       XI  = ZERO
12243       Q2I = ZERO
12244 *
12245 *  initialize nuclear parameters, etc.
12246
12247 *  initialize evaporation if the code is not used as Fluka event generator
12248       IF (ITRSPT.NE.1) THEN
12249          CALL NCDTRD
12250          CALL INCINI
12251       ENDIF
12252
12253 *
12254 *  open Glauber-data output file
12255       IDX = INDEX(CGLB,' ')
12256       K   = 12
12257       IF (IDX.GT.1) K = IDX-1
12258       OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12259 *
12260 *--------------------------------------------------------------------------
12261 * Glauber-initialization for proton and nuclei projectiles
12262 *
12263 *  initialize phojet for proton-proton interactions
12264       ELAB = ZERO
12265       PLAB = ZERO
12266       CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12267       CALL DT_PHOINI
12268 *
12269 *  record projectile masses
12270       NASAV = 0
12271       NPROJ = MIN(IP,JPEACH)
12272       DO 10 KPROJ=1,NPROJ
12273          NASAV = NASAV+1
12274          IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12275          IASAV(NASAV) = KPROJ
12276    10 CONTINUE
12277       IF (IP.GT.JPEACH) THEN
12278          NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
12279          IF (NPROJ.EQ.0) THEN
12280             NASAV = NASAV+1
12281             IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12282             IASAV(NASAV) = IP
12283          ELSE
12284             DO 11 IPROJ=1,NPROJ
12285                KPROJ = JPEACH+IPROJ*JPSTEP
12286                NASAV = NASAV+1
12287                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12288                IASAV(NASAV) = KPROJ
12289    11       CONTINUE
12290             IF (KPROJ.LT.IP) THEN
12291                NASAV = NASAV+1
12292                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12293                IASAV(NASAV) = IP
12294             ENDIF
12295          ENDIF
12296       ENDIF
12297 *
12298 *  record target masses
12299       NBSAV = 0
12300       NTARG = 1
12301       IF (NCOMPO.GT.0) NTARG = NCOMPO
12302       DO 12 ITARG=1,NTARG
12303          NBSAV = NBSAV+1
12304          IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
12305          IF (NCOMPO.GT.0) THEN
12306             IBSAV(NBSAV) = IEMUMA(ITARG)
12307          ELSE
12308             IBSAV(NBSAV) = IT
12309          ENDIF
12310    12 CONTINUE
12311 *
12312 *  print masses
12313       WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
12314  1000 FORMAT(I4,A,1P,2E13.5)
12315       NLINES = DBLE(NASAV)/18.0D0
12316       IF (NLINES.GT.0) THEN
12317          DO 13 I=1,NLINES
12318             IF (I.EQ.1) THEN
12319                WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
12320             ELSE
12321                WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
12322             ENDIF
12323    13    CONTINUE
12324       ENDIF
12325       I0 = 18*NLINES+1
12326       IF (I0.LE.NASAV) THEN
12327          IF (I0.EQ.1) THEN
12328             WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
12329          ELSE
12330             WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
12331          ENDIF
12332       ENDIF
12333       NLINES = DBLE(NBSAV)/18.0D0
12334       IF (NLINES.GT.0) THEN
12335          DO 14 I=1,NLINES
12336             IF (I.EQ.1) THEN
12337                WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
12338             ELSE
12339                WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
12340             ENDIF
12341    14    CONTINUE
12342       ENDIF
12343       I0 = 18*NLINES+1
12344       IF (I0.LE.NBSAV) THEN
12345          IF (I0.EQ.1) THEN
12346             WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
12347          ELSE
12348             WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
12349          ENDIF
12350       ENDIF
12351 *
12352 *  calculate Glauber-data for each energy and mass combination
12353 *
12354 *   loop over energy bins
12355       ELO = LOG10(ELO)
12356       EHI = LOG10(EHI)
12357       DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
12358       DO 1 IE=1,NEBIN+1
12359          E = ELO+DBLE(IE-1)*DEBIN
12360          E = 10**E
12361          IF (LCMS) THEN
12362             E   = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
12363             ECM = E
12364          ELSE
12365             PLAB = ZERO
12366             ECM  = ZERO
12367             E    = MAX(AAM(IJPROJ)+0.1D0,E)
12368             CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12369          ENDIF
12370 *
12371 *   loop over projectile and target masses
12372          DO 2 ITARG=1,NBSAV
12373             DO 3 IPROJ=1,NASAV
12374                CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
12375      &                                       XI,Q2I,ECM,1,1,-1)
12376     3       CONTINUE
12377     2    CONTINUE
12378 *
12379     1 CONTINUE
12380 *
12381 *--------------------------------------------------------------------------
12382 * Glauber-initialization for pion, kaon, ... projectiles
12383 *
12384       DO 6 IJ=1,MAXOFF
12385 *
12386 *  initialize phojet for this interaction
12387          ELAB = ZERO
12388          PLAB = ZERO
12389          IJPROJ = IJPINI(IJ)
12390          IP     = 1
12391          IPZ    = 1
12392 *
12393 *   temporary patch until fix has been implemented in phojet:
12394          IF (ECMINI.GT.ECMXPI) THEN
12395             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
12396          ELSE
12397             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12398          ENDIF
12399          CALL DT_PHOINI
12400 *
12401 *  calculate Glauber-data for each energy and mass combination
12402 *
12403 *   loop over energy bins
12404          DO 4 IE=1,NEBIN+1
12405             E = ELO+DBLE(IE-1)*DEBIN
12406             E = 10**E
12407             IF (LCMS) THEN
12408                E   = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
12409                ECM = E
12410             ELSE
12411                PLAB = ZERO
12412                ECM  = ZERO
12413                E    = MAX(AAM(IJPROJ)+TINY14,E)
12414                CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12415             ENDIF
12416 *
12417 *   loop over projectile and target masses
12418             DO 5 ITARG=1,NBSAV
12419                CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
12420     5       CONTINUE
12421 *
12422     4    CONTINUE
12423 *
12424     6 CONTINUE
12425
12426 *--------------------------------------------------------------------------
12427 * close output unit(s), etc.
12428 *
12429       CLOSE(LDAT)
12430
12431       RETURN
12432       END
12433
12434 *$ CREATE DT_GLBSET.FOR
12435 *COPY DT_GLBSET
12436 *
12437 *===glbset=============================================================*
12438 *
12439       SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
12440 ************************************************************************
12441 * Interpolation of pre-initialized profile functions                   *
12442 * This version dated 28.11.00 is written by S. Roesler.                *
12443 ************************************************************************
12444
12445       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12446       SAVE
12447
12448       PARAMETER ( LINP = 10 ,
12449      &            LOUT = 6 ,
12450      &            LDAT = 9 )
12451
12452       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
12453
12454       LOGICAL LCMS,LREAD,LFRST1,LFRST2
12455
12456 * particle properties (BAMJET index convention)
12457       CHARACTER*8  ANAME
12458       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12459      &                IICH(210),IIBAR(210),K1(210),K2(210)
12460
12461 * Glauber formalism: flags and parameters for statistics
12462       LOGICAL LPROD
12463       CHARACTER*8 CGLB
12464       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12465
12466       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12467
12468 * Glauber formalism: parameters
12469       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
12470      &                BMAX(NCOMPX),BSTEP(NCOMPX),
12471      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
12472      &                NSITEB,NSTATB
12473
12474 * Glauber formalism: cross sections
12475       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
12476      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
12477      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
12478      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
12479      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
12480      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12481      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12482      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12483      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12484      &                BSLOPE,NEBINI,NQBINI
12485
12486 * number of data sets other than protons and nuclei
12487 * at the moment = 2 (pions and kaons)
12488       PARAMETER (MAXOFF=2)
12489       DIMENSION IJPINI(5),IOFFST(25)
12490       DATA IJPINI / 13, 15,  0,  0,  0/
12491 * Glauber data-set to be used for hadron projectiles
12492 * (0=proton, 1=pion, 2=kaon)
12493       DATA (IOFFST(K),K=1,25) /
12494      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12495      &  0, 0, 1, 2, 2/
12496 * Acceptance interval for target nucleus mass
12497       PARAMETER (KBACC = 6)
12498
12499 * emulsion treatment
12500       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12501      &                NCOMPO,IEMUL
12502
12503       PARAMETER (MAXSET=5000,
12504      &           MAXBIN=100)
12505       DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
12506       DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
12507      &          BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
12508      &          IAIDX(10)
12509
12510       DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
12511 *
12512 * read data from file
12513 *
12514       IF (MODE.EQ.0) THEN
12515
12516          IF (LREAD) RETURN
12517
12518          DO 1 I=1,MAXSET
12519             DO 2 J=1,6
12520                XSIG(I,J) = ZERO
12521                XERR(I,J) = ZERO
12522     2       CONTINUE
12523             DO 3 J=1,KSITEB
12524                BPROFL(I,J) = ZERO
12525     3       CONTINUE
12526     1    CONTINUE
12527          DO 4 I=1,MAXBIN
12528             IABIN(I) = 0
12529             IBBIN(I) = 0
12530     4    CONTINUE
12531          DO 5 I=1,KSITEB
12532             BPRO0(I) = ZERO
12533             BPRO1(I) = ZERO
12534             BPRO(I)  = ZERO
12535     5    CONTINUE
12536
12537          IDX = INDEX(CGLB,' ')
12538          K   = 12
12539          IF (IDX.GT.1) K = IDX-1
12540          OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12541          WRITE(LOUT,1000) CGLB(1:K)//'.glb'
12542  1000    FORMAT(/,' GLBSET: impact parameter distributions read from ',
12543      &          'file ',A12,/)
12544 *
12545 *  read binning information
12546          READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
12547 *  return lower energy threshold to Fluka-interface
12548          ELAB = ELO
12549          LCMS = ELO.LT.ZERO
12550          WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
12551          IF (LCMS) THEN
12552             WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
12553          ELSE
12554             WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
12555          ENDIF
12556  1001    FORMAT(2X,A5,'  E_lo = ',1P,E9.3,'  E_hi = ',1P,E9.3,4X,
12557      &          'No. of bins:',I5,/)
12558          ELO  = LOG10(ABS(ELO))
12559          EHI  = LOG10(ABS(EHI))
12560          DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
12561          WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
12562          READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
12563          IF (NABIN.LT.18) THEN
12564             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
12565          ELSE
12566             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
12567          ENDIF
12568          IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
12569          IF (NABIN.GT.18) THEN
12570             NLINES = DBLE(NABIN-18)/18.0D0
12571             IF (NLINES.GT.0) THEN
12572                DO 7 I=1,NLINES
12573                   I0 = 18*(I+1)-17
12574                   READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12575                   WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12576     7          CONTINUE
12577             ENDIF
12578             I0 = 18*(NLINES+1)+1
12579             IF (I0.LE.NABIN) THEN
12580                READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12581                WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12582             ENDIF
12583          ENDIF
12584          WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
12585          READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
12586          IF (NBBIN.LT.18) THEN
12587             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
12588          ELSE
12589             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12590          ENDIF
12591          IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
12592          IF (NBBIN.GT.18) THEN
12593             NLINES = DBLE(NBBIN-18)/18.0D0
12594             IF (NLINES.GT.0) THEN
12595                DO 8 I=1,NLINES
12596                   I0 = 18*(I+1)-17
12597                   READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12598                   WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12599     8          CONTINUE
12600             ENDIF
12601             I0 = 18*(NLINES+1)+1
12602             IF (I0.LE.NBBIN) THEN
12603                READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12604                WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12605             ENDIF
12606          ENDIF
12607 *  number of data sets to follow in the Glauber data file
12608 *   this variable is used for checks of consistency of projectile
12609 *   and target mass configurations given in header of Glauber data
12610 *   file and the data-sets which follow in this file
12611          NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12612 *
12613 *  read profile function data
12614          NSET  = 0
12615          NAIDX = 0
12616          IPOLD = 0
12617    10    CONTINUE
12618          NSET = NSET+1
12619          IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12620          READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12621  1002    FORMAT(5I10,E15.5)
12622          IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12623             NAIDX = NAIDX+1
12624             IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12625             IAIDX(NAIDX) = IP
12626             IPOLD = IP
12627          ENDIF
12628          READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12629          READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12630          NLINES = INT(DBLE(ISITEB)/7.0D0)
12631          IF (NLINES.GT.0) THEN
12632             DO 11 I=1,NLINES
12633                READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12634    11       CONTINUE
12635          ENDIF
12636          I0 = 7*NLINES+1
12637          IF (I0.LE.ISITEB)
12638      &      READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12639          GOTO 10
12640   100    CONTINUE
12641          NSET = NSET-1
12642          IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12643          WRITE(LOUT,'(/,1X,A)')
12644      &   ' projectiles other than protons and nuclei: (particle index)'
12645          IF (NAIDX.GT.0) THEN
12646             WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12647          ELSE
12648             WRITE(LOUT,'(6X,A)') 'none'
12649          ENDIF
12650 *
12651          CLOSE(LDAT)
12652          WRITE(LOUT,*)
12653          LREAD = .TRUE.
12654
12655          IF (NCOMPO.EQ.0) THEN
12656             DO 12 J=1,NBBIN
12657                NCOMPO = NCOMPO+1
12658                IEMUMA(NCOMPO) = IBBIN(J)
12659                IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12660                EMUFRA(NCOMPO) = 1.0D0
12661    12       CONTINUE
12662             IEMUL = 1
12663          ENDIF
12664 *
12665 * calculate profile function for certain set of parameters
12666 *
12667       ELSE
12668
12669 c        write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12670 *
12671 * check for type of projectile and set index-offset to entry in
12672 * Glauber data array correspondingly
12673          IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12674          IF (IOFFST(IDPROJ).EQ.-1) THEN
12675             STOP ' GLBSET: no data for this projectile !'
12676          ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12677             IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12678          ELSE
12679             IDXOFF = 0
12680          ENDIF
12681 *
12682 * get energy bin and interpolation factor
12683          IF (LCMS) THEN
12684             E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12685          ELSE
12686             E = ELAB
12687          ENDIF
12688          E = LOG10(E)
12689          IF (E.LT.ELO) THEN
12690             IF (LFRST1) THEN
12691                WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12692                LFRST1 = .FALSE.
12693             ENDIF
12694             E = ELO
12695          ENDIF
12696          IF (E.GT.EHI) THEN
12697             IF (LFRST2) THEN
12698                WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12699                LFRST2 = .FALSE.
12700             ENDIF
12701             E = EHI
12702          ENDIF
12703          IE0  = (E-ELO)/DEBIN+1
12704          IE1  = IE0+1
12705          FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12706 *
12707 * get target nucleus index
12708          KB = 0
12709          NBACC = KBACC
12710          DO 20 I=1,NBBIN
12711             NBDIFF = ABS(NB-IBBIN(I))
12712             IF (NB.EQ.IBBIN(I)) THEN
12713                KB = I
12714                GOTO 21
12715             ELSEIF (NBDIFF.LE.NBACC) THEN
12716                KB = I
12717                NBACC = NBDIFF
12718             ENDIF
12719    20    CONTINUE
12720          IF (KB.NE.0) GOTO 21
12721          WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12722          STOP
12723    21    CONTINUE
12724 *
12725 * get projectile nucleus bin and interpolation factor
12726          KA0 = 0
12727          KA1 = 0
12728          FACNA = 0
12729          IF (IDXOFF.GT.0) THEN
12730             KA0 = 1
12731             KA1 = 1
12732             KABIN = 1
12733          ELSE
12734             IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12735             DO 22 I=1,NABIN
12736                IF (NA.EQ.IABIN(I)) THEN
12737                   KA0 = I
12738                   KA1 = I
12739                   GOTO 23
12740                ELSEIF (NA.LT.IABIN(I)) THEN
12741                   KA0 = I-1
12742                   KA1 = I
12743                   GOTO 23
12744                ENDIF
12745    22       CONTINUE
12746             WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12747             STOP
12748    23       CONTINUE
12749             IF (KA0.NE.KA1)
12750      &         FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12751             KABIN = NABIN
12752          ENDIF
12753 *
12754 * interpolate profile functions for interactions ka0-kb and ka1-kb
12755 * for energy E separately
12756          IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12757          IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12758          IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12759          IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12760          DO 30 I=1,ISITEB
12761             BPRO0(I) = BPROFL(IDX0,I)
12762      &                 +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12763             BPRO1(I) = BPROFL(IDY0,I)
12764      &                 +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12765    30    CONTINUE
12766          RADB  = DT_RNCLUS(NB)
12767          BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12768          BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12769 *
12770 * interpolate cross sections for energy E and projectile mass
12771          DO 31 I=1,6
12772             XS0   = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12773             XS1   = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12774             XS(I) = XS0+FACNA*(XS1-XS0)
12775             XE0   = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12776             XE1   = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12777             XE(I) = XE0+FACNA*(XE1-XE0)
12778    31    CONTINUE
12779 *
12780 * interpolate between ka0 and ka1
12781          RADA = DT_RNCLUS(NA)
12782          BMX  = 2.0D0*(RADA+RADB)
12783          BSTP = BMX/DBLE(ISITEB-1)
12784          BPRO(1) = ZERO
12785          DO 32 I=1,ISITEB-1
12786             B = DBLE(I)*BSTP
12787 *
12788 *   calculate values of profile functions at B
12789             IDX0 = B/BSTP0+1
12790             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12791             IDX1 = MIN(IDX0+1,ISITEB)
12792             FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12793             BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12794             IDX0 = B/BSTP1+1
12795             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12796             IDX1 = MIN(IDX0+1,ISITEB)
12797             FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12798             BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12799 *
12800             BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12801    32    CONTINUE
12802 *
12803 * fill common dtglam
12804          NSITEB   = ISITEB
12805          RASH(1)  = RADA
12806          RBSH(1)  = RADB
12807          BMAX(1)  = BMX
12808          BSTEP(1) = BSTP
12809          DO 33 I=1,KSITEB
12810             BSITE(0,1,1,I) = BPRO(I)
12811    33    CONTINUE
12812 *
12813 * fill common dtglxs
12814          XSTOT(1,1,1) = XS(1)
12815          XSELA(1,1,1) = XS(2)
12816          XSQEP(1,1,1) = XS(3)
12817          XSQET(1,1,1) = XS(4)
12818          XSQE2(1,1,1) = XS(5)
12819          XSPRO(1,1,1) = XS(6)
12820          XETOT(1,1,1) = XE(1)
12821          XEELA(1,1,1) = XE(2)
12822          XEQEP(1,1,1) = XE(3)
12823          XEQET(1,1,1) = XE(4)
12824          XEQE2(1,1,1) = XE(5)
12825          XEPRO(1,1,1) = XE(6)
12826
12827       ENDIF
12828
12829       RETURN
12830       END
12831 *$ CREATE DT_XKSAMP.FOR
12832 *COPY DT_XKSAMP
12833 *
12834 *===xksamp=============================================================*
12835 *
12836       SUBROUTINE DT_XKSAMP(NN,ECM)
12837
12838 ************************************************************************
12839 * Sampling of parton x-values and chain system for one interaction.    *
12840 *                                   processed by S. Roesler, 9.8.95    *
12841 ************************************************************************
12842
12843       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12844       SAVE
12845
12846       PARAMETER ( LINP = 10 ,
12847      &            LOUT = 6 ,
12848      &            LDAT = 9 )
12849
12850       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12851       SAVE
12852
12853       PARAMETER (
12854 * lower cuts for (valence-sea/sea-valence) chain masses
12855 *   antiquark-quark (u/d-sea quark)    (s-sea quark)
12856      &               AMIU = 0.5D0,      AMIS = 0.8D0,
12857 *   quark-diquark   (u/d-sea quark)    (s-sea quark)
12858      &               AMAU = 2.6D0,      AMAS = 2.6D0,
12859 * maximum lower valence-x threshold
12860      &           XVMAX  = 0.98D0,
12861 * fraction of sea-diquarks sampled out of sea-partons
12862 **test
12863 C    &           FRCDIQ = 0.9D0,
12864 **
12865 *
12866      &           SQMA   = 0.7D0,
12867 *
12868 * maximum number of trials to generate x's for the required number
12869 * of sea quark pairs for a given hadron
12870      &           NSEATY = 12
12871 C    &           NSEATY = 3
12872      &          )
12873
12874       LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12875
12876       PARAMETER ( MAXNCL = 260,
12877
12878      &            MAXVQU = MAXNCL,
12879      &            MAXSQU = 20*MAXVQU,
12880      &            MAXINT = MAXVQU+MAXSQU)
12881
12882 * event history
12883
12884       PARAMETER (NMXHKK=200000)
12885
12886       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12887      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12888      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12889
12890 * particle properties (BAMJET index convention)
12891       CHARACTER*8  ANAME
12892       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12893      &                IICH(210),IIBAR(210),K1(210),K2(210)
12894
12895 * interface between Glauber formalism and DPM
12896       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12897      &                INTER1(MAXINT),INTER2(MAXINT)
12898
12899 * properties of interacting particles
12900       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12901
12902 * threshold values for x-sampling (DTUNUC 1.x)
12903       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12904      &                SSMIMQ,VVMTHR
12905
12906 * x-values of partons (DTUNUC 1.x)
12907       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12908      &                XTVQ(MAXVQU),XTVD(MAXVQU),
12909      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
12910      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
12911
12912 * flavors of partons (DTUNUC 1.x)
12913       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12914      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12915      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
12916      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12917      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
12918      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12919      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
12920
12921 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12922       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12923      &                IXPV,IXPS,IXTV,IXTS,
12924      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
12925      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
12926      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
12927      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
12928      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
12929      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
12930      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
12931      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
12932
12933 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12934       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12935      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12936
12937 * auxiliary common for chain system storage (DTUNUC 1.x)
12938       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12939
12940 * flags for input different options
12941       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12942       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12943      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12944
12945 * various options for treatment of partons (DTUNUC 1.x)
12946 * (chain recombination, Cronin,..)
12947       LOGICAL LCO2CR,LINTPT
12948       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12949      &                LCO2CR,LINTPT
12950
12951       DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12952      &          INTLO(MAXINT)
12953
12954 * (1) initializations
12955 *-----------------------------------------------------------------------
12956
12957 **test
12958       IF (ECM.LT.4.5D0) THEN
12959 C        FRCDIQ = 0.6D0
12960          FRCDIQ = 0.4D0
12961       ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12962 C        FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12963          FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12964       ELSE
12965 C        FRCDIQ = 0.9D0
12966          FRCDIQ = 0.7D0
12967       ENDIF
12968 **
12969       DO 30 I=1,MAXSQU
12970          ZUOSP(I) = .FALSE.
12971          ZUOST(I) = .FALSE.
12972          IF (I.LE.MAXVQU) THEN
12973             ZUOVP(I) = .FALSE.
12974             ZUOVT(I) = .FALSE.
12975          ENDIF
12976    30 CONTINUE
12977
12978 * lower thresholds for x-selection
12979 *  sea-quarks       (default: CSEA=0.2)
12980       IF (ECM.LT.10.0D0) THEN
12981 **!!test
12982          XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12983 C        XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12984          NSEA  = NSEATY
12985 C        XSTHR = ONE/ECM**2
12986       ELSE
12987 **sr 30.3.98
12988 C        XSTHR = CSEA/ECM
12989          XSTHR = CSEA/ECM**2
12990 C        XSTHR = ONE/ECM**2
12991 **
12992          IF ((IP.GE.150).AND.(IT.GE.150))
12993      &      XSTHR = 2.5D0/(ECM*SQRT(ECM))
12994          NSEA  = NSEATY
12995       ENDIF
12996 *                   (default: SSMIMA=0.14) used for sea-diquarks (?)
12997       XSSTHR = SSMIMA/ECM
12998       BSQMA  = SQMA/ECM
12999 *  valence-quarks   (default: CVQ=1.0)
13000       XVTHR  = CVQ/ECM
13001 *  valence-diquarks (default: CDQ=2.0)
13002       XDTHR  = CDQ/ECM
13003
13004 * maximum-x for sea-quarks
13005       XVCUT  = XVTHR+XDTHR
13006       IF (XVCUT.GT.XVMAX) THEN
13007          XVCUT = XVMAX
13008          XVTHR = XVCUT/3.0D0
13009          XDTHR = XVCUT-XVTHR
13010       ENDIF
13011       XXSEAM = ONE-XVCUT
13012 **sr 18.4. test: DPMJET
13013 C     XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
13014 C    &            - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
13015 C    &             -0.01*(1.D0+1.5D0*DT_RNDM(V3))
13016 **
13017 * maximum number of sea-pairs allowed kinematically
13018 C     NSMAX  = INT(OHALF*XXSEAM/XSTHR)
13019       RNSMAX = OHALF*XXSEAM/XSTHR
13020       IF (RNSMAX.GT.10000.0D0) THEN
13021          NSMAX = 10000
13022       ELSE
13023          NSMAX = INT(OHALF*XXSEAM/XSTHR)
13024       ENDIF
13025 * check kinematical limit for valence-x thresholds
13026 * (should be obsolete now)
13027       IF (XVCUT.GT.XVMAX) THEN
13028          WRITE(LOUT,1000) XVCUT,ECM
13029  1000    FORMAT(' XKSAMP:    kin. limit for valence-x',
13030      &          '  thresholds not allowed (',2E9.3,')')
13031 C        XVTHR = XVMAX-XDTHR
13032 C        IF (XVTHR.LT.ZERO) STOP
13033          STOP
13034       ENDIF
13035
13036 * set eta for valence-x sampling (BETREJ)
13037 *   (UNON per default, UNOM used for projectile mesons only)
13038       IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
13039          UNOPRV = UNOM
13040       ELSE
13041          UNOPRV = UNON
13042       ENDIF
13043
13044 * (2) select parton x-values of interacting projectile nucleons
13045 *-----------------------------------------------------------------------
13046
13047       IXPV = 0
13048       IXPS = 0
13049
13050       DO 100 IPP=1,IP
13051 *   get interacting projectile nucleon as sampled by Glauber
13052          IF (JSSH(IPP).NE.0) THEN
13053             IXSTMP = IXPS
13054             IXVTMP = IXPV
13055    99       CONTINUE
13056             IXPS   = IXSTMP
13057             IXPV   = IXVTMP
13058 *     JIPP is the actual number of sea-pairs sampled for this nucleon
13059             JIPP   = MIN(JSSH(IPP)-1,NSMAX)
13060    41       CONTINUE
13061             XXSEA  = ZERO
13062             IF (JIPP.GT.0) THEN
13063                XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
13064 *???
13065                IF (XSTHR.GE.XSMAX) THEN
13066                   JIPP = JIPP-1
13067                   GOTO 41
13068                ENDIF
13069
13070 *>>>get x-values of sea-quark pairs
13071                NSCOUN = 0
13072                PLW = 0.5D0
13073    40          CONTINUE
13074 *     accumulator for sea x-values
13075                XXSEA  = ZERO
13076                NSCOUN = NSCOUN+1
13077                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13078                IF (NSCOUN.GT.NSEA) THEN
13079 *     decrease the number of interactions after NSEA trials
13080                   JIPP   = JIPP-1
13081                   NSCOUN = 0
13082                ENDIF
13083                DO 70 ISQ=1,JIPP
13084 *     sea-quarks
13085                   IF (IPSQ(IXPS+1).LE.2) THEN
13086 **sr 8.4.98 (1/sqrt(x))
13087 C                    XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13088 C                    XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13089                      XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13090 **
13091                   ELSE
13092                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13093                         XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13094                      ELSE
13095 **sr 8.4.98 (1/sqrt(x))
13096 C                       XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13097 C                       XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13098                         XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13099 **
13100                      ENDIF
13101                   ENDIF
13102 *     sea-antiquarks
13103                   IF (IPSAQ(IXPS+1).GE.-2) THEN
13104 **sr 8.4.98 (1/sqrt(x))
13105 C                    XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13106 C                    XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13107                      XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13108 **
13109                   ELSE
13110                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13111                         XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13112                      ELSE
13113 **sr 8.4.98 (1/sqrt(x))
13114 C                       XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13115 C                       XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13116                         XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13117 **
13118                      ENDIF
13119                   ENDIF
13120                   XXSEA = XXSEA+XPSQI+XPSAQI
13121 *     check for maximum allowed sea x-value
13122                   IF (XXSEA.GE.XXSEAM) THEN
13123                      IXPS = IXPS-ISQ+1
13124                      GOTO 40
13125                   ENDIF
13126 *     accept this sea-quark pair
13127                   IXPS         = IXPS+1
13128                   XPSQ(IXPS)   = XPSQI
13129                   XPSAQ(IXPS)  = XPSAQI
13130                   IFROSP(IXPS) = IPP
13131                   ZUOSP(IXPS)  = .TRUE.
13132    70          CONTINUE
13133             ENDIF
13134
13135 *>>>get x-values of valence partons
13136 *     valence quark
13137             IF (XVTHR.GT.0.05D0) THEN
13138                XVHI  = ONE-XXSEA-XDTHR
13139                XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
13140             ELSE
13141    90          CONTINUE
13142                XPVQI = DT_DBETAR(OHALF,UNOPRV)
13143                IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
13144      &                                                     GOTO 90
13145             ENDIF
13146 *     valence diquark
13147             XPVDI = ONE-XPVQI-XXSEA
13148 *       reject according to x**1.5
13149             XDTMP = XPVDI**1.5D0
13150             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
13151 *     accept these valence partons
13152             IXPV         = IXPV+1
13153             XPVQ(IXPV)   = XPVQI
13154             XPVD(IXPV)   = XPVDI
13155             IFROVP(IXPV) = IPP
13156             ITOVP(IPP)   = IXPV
13157             ZUOVP(IXPV)  = .TRUE.
13158
13159          ENDIF
13160   100 CONTINUE
13161
13162 * (3) select parton x-values of interacting target nucleons
13163 *-----------------------------------------------------------------------
13164
13165       IXTV = 0
13166       IXTS = 0
13167
13168       DO 170 ITT=1,IT
13169 *   get interacting target nucleon as sampled by Glauber
13170          IF (JTSH(ITT).NE.0) THEN
13171             IXSTMP = IXTS
13172             IXVTMP = IXTV
13173   169       CONTINUE
13174             IXTS   = IXSTMP
13175             IXTV   = IXVTMP
13176 *     JITT is the actual number of sea-pairs sampled for this nucleon
13177             JITT   = MIN(JTSH(ITT)-1,NSMAX)
13178   111       CONTINUE
13179             XXSEA  = ZERO
13180             IF (JITT.GT.0) THEN
13181                XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
13182 *???
13183                IF (XSTHR.GE.XSMAX) THEN
13184                   JITT = JITT-1
13185                   GOTO 111
13186                ENDIF
13187
13188 *>>>get x-values of sea-quark pairs
13189                NSCOUN = 0
13190                PLW = 0.5D0
13191   110          CONTINUE
13192 *     accumulator for sea x-values
13193                XXSEA  = ZERO
13194                NSCOUN = NSCOUN+1
13195                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13196                IF (NSCOUN.GT.NSEA)THEN
13197 *     decrease the number of interactions after NSEA trials
13198                   JITT   = JITT-1
13199                   NSCOUN = 0
13200                ENDIF
13201                DO 140 ISQ=1,JITT
13202 *     sea-quarks
13203                   IF (ITSQ(IXTS+1).LE.2) THEN
13204 **sr 8.4.98 (1/sqrt(x))
13205 C                    XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13206 C                    XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13207                      XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13208 **
13209                   ELSE
13210                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13211                         XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13212                      ELSE
13213 **sr 8.4.98 (1/sqrt(x))
13214 C                       XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13215 C                       XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13216                         XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13217 **
13218                      ENDIF
13219                   ENDIF
13220 *     sea-antiquarks
13221                   IF (ITSAQ(IXTS+1).GE.-2) THEN
13222 **sr 8.4.98 (1/sqrt(x))
13223 C                    XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13224 C                    XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13225                      XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13226 **
13227                   ELSE
13228                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13229                         XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13230                      ELSE
13231 **sr 8.4.98 (1/sqrt(x))
13232 C                       XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13233 C                       XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13234                         XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13235 **
13236                      ENDIF
13237                   ENDIF
13238                   XXSEA = XXSEA+XTSQI+XTSAQI
13239 *     check for maximum allowed sea x-value
13240                   IF (XXSEA.GE.XXSEAM) THEN
13241                      IXTS = IXTS-ISQ+1
13242                      GOTO 110
13243                   ENDIF
13244 *     accept this sea-quark pair
13245                   IXTS         = IXTS+1
13246                   XTSQ(IXTS)   = XTSQI
13247                   XTSAQ(IXTS)  = XTSAQI
13248                   IFROST(IXTS) = ITT
13249                   ZUOST(IXTS)  = .TRUE.
13250   140          CONTINUE
13251             ENDIF
13252
13253 *>>>get x-values of valence partons
13254 *     valence quark
13255             IF (XVTHR.GT.0.05D0) THEN
13256                XVHI  = ONE-XXSEA-XDTHR
13257                XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
13258             ELSE
13259   160          CONTINUE
13260                XTVQI = DT_DBETAR(OHALF,UNON)
13261                IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
13262      &                                                    GOTO 160
13263             ENDIF
13264 *     valence diquark
13265             XTVDI = ONE-XTVQI-XXSEA
13266 *       reject according to x**1.5
13267             XDTMP = XTVDI**1.5D0
13268             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
13269 *     accept these valence partons
13270             IXTV         = IXTV+1
13271             XTVQ(IXTV)   = XTVQI
13272             XTVD(IXTV)   = XTVDI
13273             IFROVT(IXTV) = ITT
13274             ITOVT(ITT)   = IXTV
13275             ZUOVT(IXTV)  = .TRUE.
13276
13277          ENDIF
13278   170 CONTINUE
13279
13280 * (4) get valence-valence chains
13281 *-----------------------------------------------------------------------
13282
13283       NVV = 0
13284       DO 240 I=1,NN
13285          INTLO(I) = .TRUE.
13286          IPVAL    = ITOVP(INTER1(I))
13287          ITVAL    = ITOVT(INTER2(I))
13288          IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
13289             INTLO(I)      = .FALSE.
13290             ZUOVP(IPVAL)  = .FALSE.
13291             ZUOVT(ITVAL)  = .FALSE.
13292             NVV           = NVV+1
13293             ISKPCH(8,NVV) = 0
13294             INTVV1(NVV)   = IPVAL
13295             INTVV2(NVV)   = ITVAL
13296          ENDIF
13297   240 CONTINUE
13298
13299 * (5) get sea-valence chains
13300 *-----------------------------------------------------------------------
13301
13302       NSV = 0
13303       NDV = 0
13304       PLW = 0.5D0
13305       DO 270 I=1,NN
13306          IF (INTLO(I)) THEN
13307             IPVAL = ITOVP(INTER1(I))
13308             ITVAL = ITOVT(INTER2(I))
13309             DO 250 J=1,IXPS
13310                IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
13311      &                                ZUOVT(ITVAL)) THEN
13312                   ZUOSP(J)     = .FALSE.
13313                   ZUOVT(ITVAL) = .FALSE.
13314                   INTLO(I)     = .FALSE.
13315                   IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
13316 *   sample sea-diquark pair
13317                      CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
13318                      IF (IREJ1.EQ.0) GOTO 260
13319                   ENDIF
13320                   NSV           = NSV+1
13321                   ISKPCH(4,NSV) = 0
13322                   INTSV1(NSV)   = J
13323                   INTSV2(NSV)   = ITVAL
13324
13325 *>>>correct chain kinematics according to minimum chain masses
13326 *     the actual chain masses
13327                   AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
13328                   AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
13329 *     get lower mass cuts
13330                   IF (IPSQ(J).EQ.3) THEN
13331 *       q being s-quark
13332                      AMCHK1 = AMAS
13333                      AMCHK2 = AMIS
13334                   ELSE
13335 *       q being u/d-quark
13336                      AMCHK1 = AMAU
13337                      AMCHK2 = AMIU
13338                   ENDIF
13339 *       q-qq chain
13340 *         chain mass above minimum - resampling of sea-q x-value
13341                   IF (AMSVQ1.GT.AMCHK1) THEN
13342                      XPSQTH      = AMCHK1/(XTVD(ITVAL)*ECM**2)
13343 **sr 8.4.98 (1/sqrt(x))
13344 C                    XPSQXX      = DT_SAMPEX(XPSQTH,XPSQ(J))
13345 C                    XPSQXX      = DT_SAMSQX(XPSQTH,XPSQ(J))
13346                      XPSQXX      = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
13347 **
13348                      XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
13349                      XPSQ(J)     = XPSQXX
13350 *         chain mass below minimum - reset sea-q x-value and correct
13351 *                                    diquark-x of the same nucleon
13352                   ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13353                      XPSQW       = AMCHK1/(XTVD(ITVAL)*ECM**2)
13354                      DXPSQ       = XPSQW-XPSQ(J)
13355                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13356                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13357                         XPSQ(J)     = XPSQW
13358                      ENDIF
13359                   ENDIF
13360 *       aq-q chain
13361 *         chain mass below minimum - reset sea-aq x-value and correct
13362 *                                    diquark-x of the same nucleon
13363                   IF (AMSVQ2.LT.AMCHK2) THEN
13364                      XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
13365                      DXPSQ = XPSQW-XPSAQ(J)
13366                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13367                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13368                         XPSAQ(J)    = XPSQW
13369                      ENDIF
13370                   ENDIF
13371 *>>>end of chain mass correction
13372
13373                   GOTO 260
13374                ENDIF
13375   250       CONTINUE
13376          ENDIF
13377   260    CONTINUE
13378   270 CONTINUE
13379
13380 * (6) get valence-sea chains
13381 *-----------------------------------------------------------------------
13382
13383       NVS = 0
13384       NVD = 0
13385       DO 300 I=1,NN
13386          IF (INTLO(I)) THEN
13387             IPVAL = ITOVP(INTER1(I))
13388             ITVAL = ITOVT(INTER2(I))
13389             DO 280 J=1,IXTS
13390                IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
13391      &                  (IFROST(J).EQ.INTER2(I))) THEN
13392                   ZUOST(J)     = .FALSE.
13393                   ZUOVP(IPVAL) = .FALSE.
13394                   INTLO(I)     = .FALSE.
13395                   IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13396 *   sample sea-diquark pair
13397                      CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
13398                      IF (IREJ1.EQ.0) GOTO 290
13399                   ENDIF
13400                   NVS           = NVS + 1
13401                   ISKPCH(6,NVS) = 0
13402                   INTVS1(NVS)   = IPVAL
13403                   INTVS2(NVS)   = J
13404
13405 *>>>correct chain kinematics according to minimum chain masses
13406 *     the actual chain masses
13407                   AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
13408                   AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
13409 *     get lower mass cuts
13410                   IF (ITSQ(J).EQ.3) THEN
13411 *       q being s-quark
13412                      AMCHK1 = AMIS
13413                      AMCHK2 = AMAS
13414                   ELSE
13415 *       q being u/d-quark
13416                      AMCHK1 = AMIU
13417                      AMCHK2 = AMAU
13418                   ENDIF
13419 *       q-aq chain
13420 *         chain mass below minimum - reset sea-aq x-value and correct
13421 *                                    diquark-x of the same nucleon
13422                   IF (AMVSQ1.LT.AMCHK1) THEN
13423                      XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
13424                      DXTSQ = XTSQW-XTSAQ(J)
13425                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13426                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13427                         XTSAQ(J)    = XTSQW
13428                      ENDIF
13429                   ENDIF
13430 *       qq-q chain
13431 *         chain mass above minimum - resampling of sea-q x-value
13432                   IF (AMVSQ2.GT.AMCHK2) THEN
13433                      XTSQTH      = AMCHK2/(XPVD(IPVAL)*ECM**2)
13434 **sr 8.4.98 (1/sqrt(x))
13435 C                    XTSQXX      = DT_SAMPEX(XTSQTH,XTSQ(J))
13436 C                    XTSQXX      = DT_SAMSQX(XTSQTH,XTSQ(J))
13437                      XTSQXX      = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13438 **
13439                      XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
13440                      XTSQ(J)     = XTSQXX
13441 *         chain mass below minimum - reset sea-q x-value and correct
13442 *                                    diquark-x of the same nucleon
13443                   ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13444                      XTSQW       = AMCHK2/(XPVD(IPVAL)*ECM**2)
13445                      DXTSQ       = XTSQW-XTSQ(J)
13446                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13447                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13448                         XTSQ(J)     = XTSQW
13449                      ENDIF
13450                   ENDIF
13451 *>>>end of chain mass correction
13452
13453                   GOTO 290
13454                ENDIF
13455   280       CONTINUE
13456          ENDIF
13457   290    CONTINUE
13458   300 CONTINUE
13459
13460 * (7) get sea-sea chains
13461 *-----------------------------------------------------------------------
13462
13463       NSS = 0
13464       NDS = 0
13465       NSD = 0
13466       DO 420 I=1,NN
13467          IF (INTLO(I)) THEN
13468             IPVAL = ITOVP(INTER1(I))
13469             ITVAL = ITOVT(INTER2(I))
13470 *   loop over target partons not yet matched
13471             DO 400 J=1,IXTS
13472                IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
13473 *   loop over projectile partons not yet matched
13474                   DO 390 JJ=1,IXPS
13475                      IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
13476                         ZUOSP(JJ)     = .FALSE.
13477                         ZUOST(J)      = .FALSE.
13478                         INTLO(I)      = .FALSE.
13479                         NSS           = NSS+1
13480                         ISKPCH(1,NSS) = 0
13481                         INTSS1(NSS)   = JJ
13482                         INTSS2(NSS)   = J
13483
13484 *---->chain recombination option
13485                         VALFRA        = DBLE(NVV/(NVV+IXPS+IXTS))
13486                         IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
13487      &                                                             THEN
13488 *       sea-sea chains may recombine with valence-valence chains
13489 *       only if they have the same projectile or target nucleon
13490                            DO 4201 IVV=1,NVV
13491                               IF (ISKPCH(8,IVV).NE.99) THEN
13492                                  IXVPR = INTVV1(IVV)
13493                                  IXVTA = INTVV2(IVV)
13494                                  IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
13495      &                               (INTER2(I).EQ.IFROVT(IXVTA))) THEN
13496 *         recombination possible, drop old v-v and s-s chains
13497                                     ISKPCH(1,NSS) = 99
13498                                     ISKPCH(8,IVV) = 99
13499
13500 *         (a) assign new s-v chains
13501 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
13502                                     IF (LSEADI.AND.
13503      &                                  (DT_RNDM(VALFRA).GT.FRCDIQ))
13504      &                                                             THEN
13505 *           sample sea-diquark pair
13506                                        CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
13507      &                                                      IREJ1)
13508                                        IF (IREJ1.EQ.0) GOTO 4202
13509                                     ENDIF
13510                                     NSV           = NSV+1
13511                                     ISKPCH(4,NSV) = 0
13512                                     INTSV1(NSV)   = JJ
13513                                     INTSV2(NSV)   = IXVTA
13514 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13515 *           the actual chain masses
13516                                     AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
13517      &                                                     *ECM**2
13518                                     AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
13519      &                                                     *ECM**2
13520 *           get lower mass cuts
13521                                     IF (IPSQ(JJ).EQ.3) THEN
13522 *             q being s-quark
13523                                        AMCHK1 = AMAS
13524                                        AMCHK2 = AMIS
13525                                     ELSE
13526 *             q being u/d-quark
13527                                        AMCHK1 = AMAU
13528                                        AMCHK2 = AMIU
13529                                     ENDIF
13530 *           q-qq chain
13531 *             chain mass above minimum - resampling of sea-q x-value
13532                                     IF (AMSVQ1.GT.AMCHK1) THEN
13533                                        XPSQTH      =
13534      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
13535 **sr 8.4.98 (1/sqrt(x))
13536                                        XPSQXX      =
13537      &                                    DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
13538 C    &                                    DT_SAMSQX(XPSQTH,XPSQ(JJ))
13539 C    &                                    DT_SAMPEX(XPSQTH,XPSQ(JJ))
13540 **
13541                                        XPVD(IPVAL) =
13542      &                                    XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
13543                                        XPSQ(JJ)    = XPSQXX
13544 *             chain mass below minimum - reset sea-q x-value and correct
13545 *                                        diquark-x of the same nucleon
13546                                     ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13547                                        XPSQW =
13548      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
13549                                        DXPSQ = XPSQW-XPSQ(JJ)
13550                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13551      &                                                            THEN
13552                                           XPVD(IPVAL) =
13553      &                                       XPVD(IPVAL)-DXPSQ
13554                                           XPSQ(JJ)    = XPSQW
13555                                        ENDIF
13556                                     ENDIF
13557 *           aq-q chain
13558 *             chain mass below minimum - reset sea-aq x-value and correct
13559 *                                        diquark-x of the same nucleon
13560                                     IF (AMSVQ2.LT.AMCHK2) THEN
13561                                        XPSQW =
13562      &                                    AMCHK2/(XTVQ(IXVTA)*ECM**2)
13563                                        DXPSQ = XPSQW-XPSAQ(JJ)
13564                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13565      &                                                            THEN
13566                                           XPVD(IPVAL) =
13567      &                                       XPVD(IPVAL)-DXPSQ
13568                                           XPSAQ(JJ)   = XPSQW
13569                                        ENDIF
13570                                     ENDIF
13571 *>>>>>>>>>>>end of chain mass correction
13572  4202                               CONTINUE
13573
13574 *         (b) assign new v-s chains
13575 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
13576                                     IF (LSEADI.AND.(
13577      &                                  DT_RNDM(AMSVQ2).GT.FRCDIQ))
13578      &                                                             THEN
13579 *           sample sea-diquark pair
13580                                        CALL DT_SAMSDQ(ECM,IXVPR,J,1,
13581      &                                                      IREJ1)
13582                                        IF (IREJ1.EQ.0) GOTO 4203
13583                                     ENDIF
13584                                     NVS           = NVS+1
13585                                     ISKPCH(6,NVS) = 0
13586                                     INTVS1(NVS)   = IXVPR
13587                                     INTVS2(NVS)   = J
13588 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13589 *           the actual chain masses
13590                                     AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
13591                                     AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
13592 *           get lower mass cuts
13593                                     IF (ITSQ(J).EQ.3) THEN
13594 *             q being s-quark
13595                                        AMCHK1 = AMIS
13596                                        AMCHK2 = AMAS
13597                                     ELSE
13598 *             q being u/d-quark
13599                                        AMCHK1 = AMIU
13600                                        AMCHK2 = AMAU
13601                                     ENDIF
13602 *           q-aq chain
13603 *             chain mass below minimum - reset sea-aq x-value and correct
13604 *                                        diquark-x of the same nucleon
13605                                     IF (AMVSQ1.LT.AMCHK1) THEN
13606                                        XTSQW =
13607      &                                    AMCHK1/(XPVQ(IXVPR)*ECM**2)
13608                                        DXTSQ = XTSQW-XTSAQ(J)
13609                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13610      &                                                            THEN
13611                                           XTVD(ITVAL) =
13612      &                                       XTVD(ITVAL)-DXTSQ
13613                                           XTSAQ(J)    = XTSQW
13614                                        ENDIF
13615                                     ENDIF
13616                                     IF (AMVSQ2.GT.AMCHK2) THEN
13617                                        XTSQTH      =
13618      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13619 **sr 8.4.98 (1/sqrt(x))
13620                                        XTSQXX      =
13621      &                                    DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13622 C    &                                    DT_SAMSQX(XTSQTH,XTSQ(J))
13623 C    &                                    DT_SAMPEX(XTSQTH,XTSQ(J))
13624 **
13625                                        XTVD(ITVAL) =
13626      &                                    XTVD(ITVAL)+XTSQ(J)-XTSQXX
13627                                        XTSQ(J)     = XTSQXX
13628                                     ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13629                                        XTSQW =
13630      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13631                                        DXTSQ = XTSQW-XTSQ(J)
13632                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13633      &                                                            THEN
13634                                           XTVD(ITVAL) =
13635      &                                       XTVD(ITVAL)-DXTSQ
13636                                           XTSQ(J)     = XTSQW
13637                                        ENDIF
13638                                     ENDIF
13639 *>>>>>>>>>end of chain mass correction
13640  4203                               CONTINUE
13641 *       jump out of s-s chain loop
13642                                     GOTO 420
13643                                  ENDIF
13644                               ENDIF
13645  4201                      CONTINUE
13646                         ENDIF
13647 *---->end of chain recombination option
13648
13649 *     sample sea-diquark pair (projectile)
13650                         IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13651                            CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13652                            IF (IREJ1.EQ.0) THEN
13653                               ISKPCH(1,NSS) = 99
13654                               GOTO 410
13655                            ENDIF
13656                         ENDIF
13657 *     sample sea-diquark pair (target)
13658                         IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13659                            CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13660                            IF (IREJ1.EQ.0) THEN
13661                               ISKPCH(1,NSS) = 99
13662                               GOTO 410
13663                            ENDIF
13664                         ENDIF
13665 *>>>>>correct chain kinematics according to minimum chain masses
13666 *     the actual chain masses
13667                         SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13668                         SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13669 *     check for lower mass cuts
13670                         IF ((SSMA1Q.LT.SSMIMQ).OR.
13671      &                      (SSMA2Q.LT.SSMIMQ)) THEN
13672                            IPVAL = ITOVP(INTER1(I))
13673                            ITVAL = ITOVT(INTER2(I))
13674                            IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13675      &                         (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13676 *       maximum allowed x values for sea quarks
13677                               XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13678      &                                           1.2D0*XSSTHR
13679                               XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13680      &                                           1.2D0*XSSTHR
13681 *       resampling of x values not possible - skip sea-sea chains
13682                               IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13683      &                            (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13684 *       resampling of x for projectile sea quark pair
13685                               ICOUS = 0
13686   310                         CONTINUE
13687                               ICOUS = ICOUS+1
13688                               IF (XSSTHR.GT.0.05D0) THEN
13689                                  XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13690      &                                                         XSPMAX)
13691                                  XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13692      &                                                         XSPMAX)
13693                               ELSE
13694   320                            CONTINUE
13695                                  XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13696                                  IF ((XPSQI.LT.XSSTHR).OR.
13697      &                               (XPSQI.GT.XSPMAX))  GOTO 320
13698   330                            CONTINUE
13699                                  XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13700                                  IF ((XPSAQI.LT.XSSTHR).OR.
13701      &                               (XPSAQI.GT.XSPMAX)) GOTO 330
13702                               ENDIF
13703 *       final test of remaining x for projectile diquark
13704                               XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13705      &                                            +XPSQ(JJ)+XPSAQ(JJ)
13706                               IF (XPVDCO.LE.XDTHR) THEN
13707 *!!!
13708 C                                IF (ICOUS.LT.5) GOTO 310
13709                                  IF (ICOUS.LT.0.5D0) GOTO 310
13710                                  GOTO 380
13711                               ENDIF
13712 *       resampling of x for target sea quark pair
13713                               ICOUS = 0
13714   350                         CONTINUE
13715                               ICOUS = ICOUS+1
13716                               IF (XSSTHR.GT.0.05D0) THEN
13717                                  XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13718      &                                                         XSTMAX)
13719                                  XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13720      &                                                         XSTMAX)
13721                               ELSE
13722   360                            CONTINUE
13723                                  XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13724                                  IF ((XTSQI.LT.XSSTHR).OR.
13725      &                               (XTSQI.GT.XSTMAX))  GOTO 360
13726   370                            CONTINUE
13727                                  XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13728                                  IF ((XTSAQI.LT.XSSTHR).OR.
13729      &                               (XTSAQI.GT.XSTMAX)) GOTO 370
13730                               ENDIF
13731 *       final test of remaining x for target diquark
13732                               XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13733      &                                            +XTSQ(J)+XTSAQ(J)
13734                               IF (XTVDCO.LT.XDTHR) THEN
13735                                  IF (ICOUS.LT.5) GOTO 350
13736                                  GOTO 380
13737                               ENDIF
13738                               XPVD(IPVAL) = XPVDCO
13739                               XTVD(ITVAL) = XTVDCO
13740                               XPSQ(JJ)    = XPSQI
13741                               XPSAQ(JJ)   = XPSAQI
13742                               XTSQ(J)     = XTSQI
13743                               XTSAQ(J)    = XTSAQI
13744 *>>>>>end of chain mass correction
13745                               GOTO 410
13746                            ENDIF
13747 *     come here to discard s-s interaction
13748 *     resampling of x values not allowed or unsuccessful
13749   380                      CONTINUE
13750                            INTLO(I)  = .FALSE.
13751                            ZUOST(J)  = .TRUE.
13752                            ZUOSP(JJ) = .TRUE.
13753                            NSS       = NSS-1
13754                         ENDIF
13755 *   consider next s-s interaction
13756                         GOTO 410
13757                      ENDIF
13758   390             CONTINUE
13759                ENDIF
13760   400       CONTINUE
13761          ENDIF
13762   410    CONTINUE
13763   420 CONTINUE
13764
13765 * correct x-values of valence quarks for non-matching sea quarks
13766       DO 430 I=1,IXPS
13767          IF (ZUOSP(I)) THEN
13768             IPVAL       = ITOVP(IFROSP(I))
13769             XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13770             XPSQ(I)     = ZERO
13771             XPSAQ(I)    = ZERO
13772             ZUOSP(I)    = .FALSE.
13773          ENDIF
13774   430 CONTINUE
13775       DO 440 I=1,IXTS
13776          IF (ZUOST(I)) THEN
13777             ITVAL       = ITOVT(IFROST(I))
13778             XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13779             XTSQ(I)     = ZERO
13780             XTSAQ(I)    = ZERO
13781             ZUOST(I)    = .FALSE.
13782          ENDIF
13783   440 CONTINUE
13784       DO 450 I=1,IXPV
13785          IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13786   450 CONTINUE
13787       DO 460 I=1,IXTV
13788          IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13789   460 CONTINUE
13790
13791       RETURN
13792       END
13793
13794 *$ CREATE DT_SAMSDQ.FOR
13795 *COPY DT_SAMSDQ
13796 *
13797 *===samsdq=============================================================*
13798 *
13799       SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13800
13801 ************************************************************************
13802 * SAMpling of Sea-DiQuarks                                             *
13803 *              ECM        cm-energy of the nucleon-nucleon system      *
13804 *              IDX1,2     indices of x-values of the participating     *
13805 *                         partons (IDX2 is always the sea-q-pair to be *
13806 *                         changed to sea-qq-pair)                      *
13807 *              MODE       = 1  valence-q - sea-diq                     *
13808 *                         = 2  sea-diq   - valence-q                   *
13809 *                         = 3  sea-q     - sea-diq                     *
13810 *                         = 4  sea-diq   - sea-q                       *
13811 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS.                               *
13812 * This version dated 17.10.95 is written by S. Roesler                 *
13813 ************************************************************************
13814
13815       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13816       SAVE
13817
13818       PARAMETER (ZERO=0.0D0)
13819
13820 * threshold values for x-sampling (DTUNUC 1.x)
13821       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13822      &                SSMIMQ,VVMTHR
13823
13824 * various options for treatment of partons (DTUNUC 1.x)
13825 * (chain recombination, Cronin,..)
13826       LOGICAL LCO2CR,LINTPT
13827       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13828      &                LCO2CR,LINTPT
13829
13830       PARAMETER ( MAXNCL = 260,
13831
13832      &            MAXVQU = MAXNCL,
13833      &            MAXSQU = 20*MAXVQU,
13834      &            MAXINT = MAXVQU+MAXSQU)
13835
13836 * x-values of partons (DTUNUC 1.x)
13837       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13838      &                XTVQ(MAXVQU),XTVD(MAXVQU),
13839      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
13840      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
13841
13842 * flavors of partons (DTUNUC 1.x)
13843       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13844      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13845      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
13846      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13847      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
13848      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13849      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
13850
13851 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13852       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13853      &                IXPV,IXPS,IXTV,IXTS,
13854      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
13855      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
13856      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
13857      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
13858      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
13859      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
13860      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
13861      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
13862
13863 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13864       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13865      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13866
13867 * auxiliary common for chain system storage (DTUNUC 1.x)
13868       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13869
13870       IREJ = 0
13871 *  threshold-x for valence diquarks
13872       XDTHR = CDQ/ECM
13873
13874       GOTO (1,2,3,4) MODE
13875
13876 *---------------------------------------------------------------------
13877 * proj. valence partons - targ. sea partons
13878 * get x-values and flavors for target sea-diquark pair
13879
13880     1 CONTINUE
13881       IDXVP = IDX1
13882       IDXST = IDX2
13883
13884 *  index of corr. val-diquark-x in target nucleon
13885       IDXVT = ITOVT(IFROST(IDXST))
13886 *  available x above diquark thresholds for valence- and sea-diquarks
13887       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13888
13889       IF (XXD.GE.ZERO) THEN
13890 *  x-values for the three diquarks of the target nucleon
13891          RR1    = DT_RNDM(XXD)
13892          RR2    = DT_RNDM(RR1)
13893          RR3    = DT_RNDM(RR2)
13894          SR123  = RR1+RR2+RR3
13895          XXTV   = XDTHR+RR1*XXD/SR123
13896          XXTSQ  = XDTHR+RR2*XXD/SR123
13897          XXTSAQ = XDTHR+RR3*XXD/SR123
13898       ELSE
13899          XXTV   = XTVD(IDXVT)
13900          XXTSQ  = XTSQ(IDXST)
13901          XXTSAQ = XTSAQ(IDXST)
13902       ENDIF
13903 *  flavor of the second quarks in the sea-diquark pair
13904       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13905       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13906 *  check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13907       AM1    = XXTSQ *XPVQ(IDXVP)*ECM**2
13908       AM2    = XXTSAQ*XPVD(IDXVP)*ECM**2
13909       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13910 *    ss-asas pair
13911      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13912          IREJ = 1
13913          RETURN
13914       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13915 *    at least one strange quark
13916      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13917          IREJ = 1
13918          RETURN
13919       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13920          IREJ = 1
13921          RETURN
13922       ENDIF
13923 *  accept the new sea-diquark
13924       XTVD(IDXVT)   = XXTV
13925       XTSQ(IDXST)   = XXTSQ
13926       XTSAQ(IDXST)  = XXTSAQ
13927       NVD           = NVD+1
13928       INTVD1(NVD)   = IDXVP
13929       INTVD2(NVD)   = IDXST
13930       ISKPCH(7,NVD) = 0
13931       RETURN
13932
13933 *---------------------------------------------------------------------
13934 * proj. sea partons - targ. valence partons
13935 * get x-values and flavors for projectile sea-diquark pair
13936
13937     2 CONTINUE
13938       IDXSP = IDX2
13939       IDXVT = IDX1
13940
13941 *  index of corr. val-diquark-x in projectile nucleon
13942       IDXVP = ITOVP(IFROSP(IDXSP))
13943 *  available x above diquark thresholds for valence- and sea-diquarks
13944       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13945
13946       IF (XXD.GE.ZERO) THEN
13947 *  x-values for the three diquarks of the projectile nucleon
13948          RR1    = DT_RNDM(XXD)
13949          RR2    = DT_RNDM(RR1)
13950          RR3    = DT_RNDM(RR2)
13951          SR123  = RR1+RR2+RR3
13952          XXPV   = XDTHR+RR1*XXD/SR123
13953          XXPSQ  = XDTHR+RR2*XXD/SR123
13954          XXPSAQ = XDTHR+RR3*XXD/SR123
13955       ELSE
13956          XXPV   = XPVD(IDXVP)
13957          XXPSQ  = XPSQ(IDXSP)
13958          XXPSAQ = XPSAQ(IDXSP)
13959       ENDIF
13960 *  flavor of the second quarks in the sea-diquark pair
13961       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13962       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13963 *  check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13964       AM1    = XXPSQ *XTVQ(IDXVT)*ECM**2
13965       AM2    = XXPSAQ*XTVD(IDXVT)*ECM**2
13966       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13967 *    ss-asas pair
13968      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13969          IREJ = 1
13970          RETURN
13971       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13972 *    at least one strange quark
13973      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13974          IREJ = 1
13975          RETURN
13976       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13977          IREJ = 1
13978          RETURN
13979       ENDIF
13980 *  accept the new sea-diquark
13981       XPVD(IDXVP)   = XXPV
13982       XPSQ(IDXSP)   = XXPSQ
13983       XPSAQ(IDXSP)  = XXPSAQ
13984       NDV           = NDV+1
13985       INTDV1(NDV)   = IDXSP
13986       INTDV2(NDV)   = IDXVT
13987       ISKPCH(5,NDV) = 0
13988       RETURN
13989
13990 *---------------------------------------------------------------------
13991 * proj. sea partons - targ. sea partons
13992 * get x-values and flavors for target sea-diquark pair
13993
13994     3 CONTINUE
13995       IDXSP = IDX1
13996       IDXST = IDX2
13997
13998 *  index of corr. val-diquark-x in target nucleon
13999       IDXVT = ITOVT(IFROST(IDXST))
14000 *  available x above diquark thresholds for valence- and sea-diquarks
14001       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
14002
14003       IF (XXD.GE.ZERO) THEN
14004 *  x-values for the three diquarks of the target nucleon
14005          RR1    = DT_RNDM(XXD)
14006          RR2    = DT_RNDM(RR1)
14007          RR3    = DT_RNDM(RR2)
14008          SR123  = RR1+RR2+RR3
14009          XXTV   = XDTHR+RR1*XXD/SR123
14010          XXTSQ  = XDTHR+RR2*XXD/SR123
14011          XXTSAQ = XDTHR+RR3*XXD/SR123
14012       ELSE
14013          XXTV   = XTVD(IDXVT)
14014          XXTSQ  = XTSQ(IDXST)
14015          XXTSAQ = XTSAQ(IDXST)
14016       ENDIF
14017 *  flavor of the second quarks in the sea-diquark pair
14018       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
14019       ITSAQ2(IDXST) = -ITSQ2(IDXST)
14020 *  check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
14021       AM1    = XXTSQ *XPSQ(IDXSP)*ECM**2
14022       AM2    = XXTSAQ*XPSAQ(IDXSP)*ECM**2
14023       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
14024 *    ss-asas pair
14025      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
14026          IREJ = 1
14027          RETURN
14028       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
14029 *    at least one strange quark
14030      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
14031          IREJ = 1
14032          RETURN
14033       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14034          IREJ = 1
14035          RETURN
14036       ENDIF
14037 *  accept the new sea-diquark
14038       XTVD(IDXVT)   = XXTV
14039       XTSQ(IDXST)   = XXTSQ
14040       XTSAQ(IDXST)  = XXTSAQ
14041       NSD           = NSD+1
14042       INTSD1(NSD)   = IDXSP
14043       INTSD2(NSD)   = IDXST
14044       ISKPCH(3,NSD) = 0
14045       RETURN
14046
14047 *---------------------------------------------------------------------
14048 * proj. sea partons - targ. sea partons
14049 * get x-values and flavors for projectile sea-diquark pair
14050
14051     4 CONTINUE
14052       IDXSP = IDX2
14053       IDXST = IDX1
14054
14055 *  index of corr. val-diquark-x in projectile nucleon
14056       IDXVP = ITOVP(IFROSP(IDXSP))
14057 *  available x above diquark thresholds for valence- and sea-diquarks
14058       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
14059
14060       IF (XXD.GE.ZERO) THEN
14061 *  x-values for the three diquarks of the projectile nucleon
14062          RR1    = DT_RNDM(XXD)
14063          RR2    = DT_RNDM(RR1)
14064          RR3    = DT_RNDM(RR2)
14065          SR123  = RR1+RR2+RR3
14066          XXPV   = XDTHR+RR1*XXD/SR123
14067          XXPSQ  = XDTHR+RR2*XXD/SR123
14068          XXPSAQ = XDTHR+RR3*XXD/SR123
14069       ELSE
14070          XXPV   = XPVD(IDXVP)
14071          XXPSQ  = XPSQ(IDXSP)
14072          XXPSAQ = XPSAQ(IDXSP)
14073       ENDIF
14074 *  flavor of the second quarks in the sea-diquark pair
14075       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
14076       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
14077 *  check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
14078       AM1    = XXPSQ *XTSQ(IDXST)*ECM**2
14079       AM2    = XXPSAQ*XTSAQ(IDXST)*ECM**2
14080       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
14081 *    ss-asas pair
14082      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
14083          IREJ = 1
14084          RETURN
14085       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
14086 *    at least one strange quark
14087      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
14088          IREJ = 1
14089          RETURN
14090       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14091          IREJ = 1
14092          RETURN
14093       ENDIF
14094 *  accept the new sea-diquark
14095       XPVD(IDXVP)   = XXPV
14096       XPSQ(IDXSP)   = XXPSQ
14097       XPSAQ(IDXSP)  = XXPSAQ
14098       NDS           = NDS+1
14099       INTDS1(NDS)   = IDXSP
14100       INTDS2(NDS)   = IDXST
14101       ISKPCH(2,NDS) = 0
14102       RETURN
14103       END
14104 *$ CREATE DT_DIFEVT.FOR
14105 *COPY DT_DIFEVT
14106 *
14107 *===difevt=============================================================*
14108 *
14109       SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
14110      &                  IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
14111
14112 ************************************************************************
14113 * Interface to treatment of diffractive interactions.                  *
14114 *  (input)          IFP1/2        PDG-indizes of projectile partons    *
14115 *                                 (baryon: IFP2 - adiquark)            *
14116 *                   PP(4)         projectile 4-momentum                *
14117 *                   IFT1/2        PDG-indizes of target partons        *
14118 *                                 (baryon: IFT1 - adiquark)            *
14119 *                   PT(4)         target 4-momentum                    *
14120 *  (output)         JDIFF = 0     no diffraction                       *
14121 *                         = 1/-1  LMSD/LMDD                            *
14122 *                         = 2/-2  HMSD/HMDD                            *
14123 *                   NCSY          counter for two-chain systems        *
14124 *                                 dumped to DTEVT1                     *
14125 * This version dated 14.02.95 is written by S. Roesler                 *
14126 ************************************************************************
14127
14128       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14129       SAVE
14130
14131       PARAMETER ( LINP = 10 ,
14132      &            LOUT = 6 ,
14133      &            LDAT = 9 )
14134
14135       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
14136      &           OHALF=0.5D0)
14137
14138 * event history
14139
14140       PARAMETER (NMXHKK=200000)
14141
14142       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14143      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14144      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14145
14146 * extended event history
14147       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14148      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14149      &                IHIST(2,NMXHKK)
14150
14151 * flags for diffractive interactions (DTUNUC 1.x)
14152       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14153
14154       DIMENSION PP(4),PT(4)
14155
14156       LOGICAL LFIRST
14157       DATA LFIRST /.TRUE./
14158
14159       IREJ   = 0
14160       JDIFF  = 0
14161       IFLAGD = JDIFF
14162
14163 * cm. energy
14164       XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
14165      &          (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
14166 * identities of projectile hadron / target nucleon
14167       KPROJ = IDT_ICIHAD(IDHKK(MOP))
14168       KTARG = IDT_ICIHAD(IDHKK(MOT))
14169
14170 * single diffractive xsections
14171       CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
14172 * double diffractive xsections
14173 **!! no double diff yet
14174 C     CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
14175       DDTOT = 0.0D0
14176       DDHM  = 0.0D0
14177 **!!
14178 * total inelastic xsection
14179 C     SIGIN  = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
14180       DUMZER = ZERO
14181       CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
14182       SIGIN  = MAX(SIGTO-SIGEL,ZERO)
14183
14184 * fraction of diffractive processes
14185       FRADIF = (SDTOT+DDTOT)/SIGIN
14186
14187       IF (LFIRST) THEN
14188          WRITE(LOUT,1000) XM,SDTOT,SIGIN
14189  1000    FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
14190      &          F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
14191      &          F5.1,' mb',/)
14192          LFIRST = .FALSE.
14193       ENDIF
14194
14195       IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
14196      &    (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
14197 * diffractive interaction requested by x-section or by user
14198          FRASD  = SDTOT/(SDTOT+DDTOT)
14199          FRASDH = SDHM/SDTOT
14200 **sr needs to be specified!!
14201 C        FRADDH = DDHM/DDTOT
14202          FRADDH = 1.0D0
14203 **
14204          IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
14205 *   single diffraction
14206             KDIFF = 1
14207             IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
14208                KP = 2
14209                KT = 0
14210                IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
14211      &               ISINGD.NE.3) THEN
14212                   KP = 0
14213                   KT = 2
14214                ENDIF
14215             ELSE
14216                KP = 1
14217                KT = 0
14218                IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
14219      &               ISINGD.NE.3) THEN
14220                   KP = 0
14221                   KT = 1
14222                ENDIF
14223             ENDIF
14224          ELSE
14225 *   double diffraction
14226             KDIFF = -1
14227             IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
14228                KP = 2
14229                KT = 2
14230             ELSE
14231                KP = 1
14232                KT = 1
14233             ENDIF
14234          ENDIF
14235          CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14236      &               IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14237          IF (IREJ1.EQ.0) THEN
14238             IFLAGD = 2*KDIFF
14239             IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
14240          ELSE
14241             GOTO 9999
14242          ENDIF
14243       ENDIF
14244       JDIFF = IFLAGD
14245
14246       RETURN
14247
14248  9999 CONTINUE
14249       IREJ  = 1
14250       RETURN
14251       END
14252
14253 *$ CREATE DT_DIFFKI.FOR
14254 *COPY DT_DIFFKI
14255 *
14256 *===difkin=============================================================*
14257 *
14258       SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14259      &                  IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
14260
14261 ************************************************************************
14262 * Kinematics of diffractive nucleon-nucleon interaction.               *
14263 *          IFP1/2   PDG-indizes of projectile partons                  *
14264 *                   (baryon: IFP2 - adiquark)                          *
14265 *          PP(4)    projectile 4-momentum                              *
14266 *          IFT1/2   PDG-indizes of target partons                      *
14267 *                   (baryon: IFT1 - adiquark)                          *
14268 *          PT(4)    target 4-momentum                                  *
14269 *          KP   = 0 projectile quasi-elastically scattered             *
14270 *               = 1            excited to low-mass diff. state         *
14271 *               = 2            excited to high-mass diff. state        *
14272 *          KT   = 0 target     quasi-elastically scattered             *
14273 *               = 1            excited to low-mass diff. state         *
14274 *               = 2            excited to high-mass diff. state        *
14275 * This version dated 12.02.95 is written by S. Roesler                 *
14276 ************************************************************************
14277
14278       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14279       SAVE
14280
14281       PARAMETER ( LINP = 10 ,
14282      &            LOUT = 6 ,
14283      &            LDAT = 9 )
14284
14285       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
14286
14287       LOGICAL LSTART
14288
14289 * particle properties (BAMJET index convention)
14290       CHARACTER*8  ANAME
14291       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14292      &                IICH(210),IIBAR(210),K1(210),K2(210)
14293
14294 * flags for input different options
14295       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14296       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14297      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14298
14299 * rejection counter
14300       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14301      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14302      &                IREXCI(3),IRDIFF(2),IRINC
14303
14304 * kinematics of diffractive interactions (DTUNUC 1.x)
14305       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14306      &                PPF(4),PTF(4),
14307      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14308      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14309
14310       DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
14311      &          PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
14312
14313       DATA LSTART /.TRUE./
14314
14315       IF (LSTART) THEN
14316          WRITE(LOUT,2000)
14317  2000    FORMAT(/,1X,'DIFEVT:  diffractive interactions treated ')
14318          LSTART = .FALSE.
14319       ENDIF
14320
14321       IREJ = 0
14322
14323 * initialize common /DTDIKI/
14324       CALL DT_DIFINI
14325 * store momenta of initial incoming particles for emc-check
14326       IF (LEMCCK) THEN
14327          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
14328          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
14329       ENDIF
14330
14331 * masses of initial particles
14332       XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
14333       XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
14334       IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
14335       XMP  = SQRT(XMP2)
14336       XMT  = SQRT(XMT2)
14337 * check quark-input (used to adjust coherence cond. for M-selection)
14338       IBP  = 0
14339       IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
14340       IBT  = 0
14341       IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
14342
14343 * parameter for Lorentz-transformation into nucleon-nucleon cms
14344       DO 3 K=1,4
14345          PITOT(K) = PP(K)+PT(K)
14346     3 CONTINUE
14347       XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
14348       IF (XMTOT2.LE.ZERO) THEN
14349          WRITE(LOUT,1000) XMTOT2
14350  1000    FORMAT(1X,'DIFEVT:   negative cm. energy!  ',
14351      &          'XMTOT2 = ',E12.3)
14352          GOTO 9999
14353       ENDIF
14354       XMTOT = SQRT(XMTOT2)
14355       DO 4 K=1,4
14356          BGTOT(K) = PITOT(K)/XMTOT
14357     4 CONTINUE
14358 * transformation of nucleons into cms
14359       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
14360      &            PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
14361       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
14362      &            PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
14363 * rotation angles
14364       COD = PP1(3)/PPTOT
14365 C     SID = SQRT((ONE-COD)*(ONE+COD))
14366       PPT = SQRT(PP1(1)**2+PP1(2)**2)
14367       SID = PPT/PPTOT
14368       COF = ONE
14369       SIF = ZERO
14370       IF(PPTOT*SID.GT.TINY10) THEN
14371          COF   = PP1(1)/(SID*PPTOT)
14372          SIF   = PP1(2)/(SID*PPTOT)
14373          ANORF = SQRT(COF*COF+SIF*SIF)
14374          COF   = COF/ANORF
14375          SIF   = SIF/ANORF
14376       ENDIF
14377 * check consistency
14378       DO 5 K=1,4
14379          DEV1(K) = ABS(PP1(K)+PT1(K))
14380     5 CONTINUE
14381       DEV1(4) = ABS(DEV1(4)-XMTOT)
14382       IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
14383      &    (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10))     THEN
14384          WRITE(LOUT,1001) DEV1
14385  1001    FORMAT(1X,'DIFEVT:   inconsitent Lorentz-transformation! ',
14386      &          /,8X,4E12.3)
14387          GOTO 9999
14388       ENDIF
14389
14390 * select x-fractions in high-mass diff. interactions
14391       IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
14392
14393 * select diffractive masses
14394 * - projectile
14395       IF (KP.EQ.1) THEN
14396          XMPF = DT_XMLMD(XMTOT)
14397          CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
14398          IF (IREJ1.GT.0) GOTO 9999
14399       ELSEIF (KP.EQ.2) THEN
14400          XMPF = DT_XMHMD(XMTOT,IBP,1)
14401       ELSE
14402          XMPF = XMP
14403       ENDIF
14404 * - target
14405       IF (KT.EQ.1) THEN
14406          XMTF = DT_XMLMD(XMTOT)
14407          CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
14408          IF (IREJ1.GT.0) GOTO 9999
14409       ELSEIF (KT.EQ.2) THEN
14410          XMTF = DT_XMHMD(XMTOT,IBT,2)
14411       ELSE
14412          XMTF = XMT
14413       ENDIF
14414
14415 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
14416       XMPF2 = XMPF**2
14417       XMTF2 = XMTF**2
14418       PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
14419       PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
14420
14421 * select momentum transfer (all t-values used here are <0)
14422 *   minimum absolute value to produce diffractive masses
14423       TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
14424       TT   = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
14425       IF (IREJ1.GT.0) GOTO 9999
14426
14427 * longitudinal momentum of excited/elastically scattered projectile
14428       PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
14429 * total transverse momentum due to t-selection
14430       PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
14431       IF (PPBLT2.LT.ZERO) THEN
14432          WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
14433  1002    FORMAT(1X,'DIFEVT:   inconsistent transverse momentum! ',
14434      &          E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
14435          GOTO 9999
14436       ENDIF
14437       CALL DT_DSFECF(SINPHI,COSPHI)
14438       PPBLT     = SQRT(PPBLT2)
14439       PPBLOB(1) = COSPHI*PPBLT
14440       PPBLOB(2) = SINPHI*PPBLT
14441
14442 * rotate excited/elastically scattered projectile into n-n cms.
14443       CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
14444      &                                                    XX,YY,ZZ)
14445       PPBLOB(1) = XX
14446       PPBLOB(2) = YY
14447       PPBLOB(3) = ZZ
14448
14449 * 4-momentum of excited/elastically scattered target and of exchanged
14450 * Pomeron
14451       DO 6 K=1,4
14452          IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
14453          PPOM1(K) = PP1(K)-PPBLOB(K)
14454     6 CONTINUE
14455       PTBLOB(4) = XMTOT-PPBLOB(4)
14456
14457 * Lorentz-transformation back into system of initial diff. collision
14458       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14459      &            PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
14460      &            PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
14461       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14462      &            PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
14463      &            PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
14464       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14465      &            PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
14466      &            PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
14467
14468 * store 4-momentum of elastically scattered particle (in single diff.
14469 * events)
14470       IF (KP.EQ.0) THEN
14471          DO 7 K=1,4
14472             PSC(K) = PPF(K)
14473     7    CONTINUE
14474       ELSEIF (KT.EQ.0) THEN
14475          DO 8 K=1,4
14476             PSC(K) = PTF(K)
14477     8    CONTINUE
14478       ENDIF
14479
14480 * check consistency of kinematical treatment so far
14481       IF (LEMCCK) THEN
14482          CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
14483          CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
14484          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
14485          IF (IREJ1.NE.0) GOTO 9999
14486       ENDIF
14487       DO 9 K=1,4
14488          DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
14489          DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
14490     9 CONTINUE
14491       IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
14492      &    (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
14493      &    (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
14494      &    (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5))     THEN
14495          WRITE(LOUT,1003) DEV1,DEV2
14496  1003    FORMAT(1X,'DIFEVT:   inconsitent kinematical treatment!  ',
14497      &          2(/,8X,4E12.3))
14498          GOTO 9999
14499       ENDIF
14500
14501 * kinematical treatment for low-mass diffraction
14502       CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
14503       IF (IREJ1.NE.0) GOTO 9999
14504
14505 * dump diffractive chains into DTEVT1
14506       CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14507       IF (IREJ1.NE.0) GOTO 9999
14508
14509       RETURN
14510
14511  9999 CONTINUE
14512       IRDIFF(1) = IRDIFF(1)+1
14513       IREJ      = 1
14514       RETURN
14515       END
14516
14517 *$ CREATE DT_XMHMD.FOR
14518 *COPY DT_XMHMD
14519 *
14520 *===xmhmd==============================================================*
14521 *
14522       DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
14523
14524 ************************************************************************
14525 * Diffractive mass in high mass single/double diffractive events.      *
14526 * This version dated 11.02.95 is written by S. Roesler                 *
14527 ************************************************************************
14528
14529       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14530       SAVE
14531
14532       PARAMETER ( LINP = 10 ,
14533      &            LOUT = 6 ,
14534      &            LDAT = 9 )
14535
14536       PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
14537
14538 * kinematics of diffractive interactions (DTUNUC 1.x)
14539       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14540      &                PPF(4),PTF(4),
14541      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14542      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14543
14544 C     DATA XCOLOW /0.05D0/
14545       DATA XCOLOW /0.15D0/
14546
14547       DT_XMHMD = ZERO
14548       XH = XPH(2)
14549       IF (MODE.EQ.2) XH = XTH(2)
14550
14551 * minimum Pomeron-x for high-mass diffraction
14552 * (adjusted to get a smooth transition between HM and LM component)
14553       R = DT_RNDM(XH)
14554       XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
14555       IF (ECM.LE.300.0D0) THEN
14556          RR     = (1.0D0-EXP(-((ECM/140.0D0)**4)))
14557          XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
14558       ENDIF
14559 * maximum Pomeron-x for high-mass diffraction
14560 * (coherence condition, adjusted to fit to experimental data)
14561       IF (IB.NE.0) THEN
14562 *   baryon-diffraction
14563          XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
14564       ELSE
14565 *   meson-diffraction
14566          XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
14567       ENDIF
14568 * check boundaries
14569       IF (XDIMIN.GE.XDIMAX) THEN
14570          XDIMIN = OHALF*XDIMAX
14571       ENDIF
14572
14573       KLOOP = 0
14574     1 CONTINUE
14575       KLOOP = KLOOP+1
14576       IF (KLOOP.GT.20) RETURN
14577 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
14578       XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
14579 * corr. diffr. mass
14580       DT_XMHMD = ECM*SQRT(XDIFF)
14581       IF (DT_XMHMD.LT.2.5D0) GOTO 1
14582
14583       RETURN
14584       END
14585
14586 *$ CREATE DT_XMLMD.FOR
14587 *COPY DT_XMLMD
14588 *
14589 *===xmlmd==============================================================*
14590 *
14591       DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
14592
14593 ************************************************************************
14594 * Diffractive mass in high mass single/double diffractive events.      *
14595 * This version dated 11.02.95 is written by S. Roesler                 *
14596 ************************************************************************
14597
14598       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14599       SAVE
14600
14601       PARAMETER ( LINP = 10 ,
14602      &            LOUT = 6 ,
14603      &            LDAT = 9 )
14604
14605 * minimum Pomeron-x for low-mass diffraction
14606 C     AMO = 1.5D0
14607       AMO = 2.0D0
14608 * maximum Pomeron-x for low-mass diffraction
14609 * (adjusted to get a smooth transition between HM and LM component)
14610       R   = DT_RNDM(AMO)
14611       SAM = 1.0D0
14612       IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
14613       R   = DT_RNDM(AMO)*SAM
14614       AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
14615       AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
14616
14617 * selection of diffractive mass
14618 * (adjusted to get a smooth transition between HM and LM component)
14619       R   = DT_RNDM(AMU)
14620       IF (ECM.LE.50.0D0) THEN
14621          DT_XMLMD = AMO*(AMU/AMO)**R
14622       ELSE
14623          A = 0.7D0
14624          IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
14625          DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
14626       ENDIF
14627
14628       RETURN
14629       END
14630
14631 *$ CREATE DT_TDIFF.FOR
14632 *COPY DT_TDIFF
14633 *
14634 *===tdiff==============================================================*
14635 *
14636       DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14637
14638 ************************************************************************
14639 * t-selection for single/double diffractive interactions.              *
14640 *          ECM      cm. energy                                         *
14641 *          TMIN     minimum momentum transfer to produce diff. masses  *
14642 *          XM1/XM2  diffractively produced masses                      *
14643 *                   (for single diffraction XM2 is obsolete)           *
14644 *          K1/K2= 0 not excited                                        *
14645 *               = 1 low-mass excitation                                *
14646 *               = 2 high-mass excitation                               *
14647 * This version dated 11.02.95 is written by S. Roesler                 *
14648 ************************************************************************
14649
14650       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14651       SAVE
14652
14653       PARAMETER ( LINP = 10 ,
14654      &            LOUT = 6 ,
14655      &            LDAT = 9 )
14656
14657       PARAMETER (ZERO=0.0D0)
14658
14659       PARAMETER ( BTP0   = 3.7D0,
14660      &            ALPHAP = 0.24D0 )
14661
14662       IREJ   = 0
14663       NCLOOP = 0
14664       DT_TDIFF  = ZERO
14665
14666       IF (K1.GT.0) THEN
14667          XM1 = XM1I
14668          XM2 = XM2I
14669       ELSE
14670          XM1 = XM2I
14671       ENDIF
14672       XDI = (XM1/ECM)**2
14673       IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14674 * slope for single diffraction
14675          SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14676       ELSE
14677 * slope for double diffraction
14678          SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14679       ENDIF
14680
14681     1 CONTINUE
14682       NCLOOP = NCLOOP+1
14683       IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14684       Y = DT_RNDM(XDI)
14685       T = -LOG(1.0D0-Y)/SLOPE
14686       IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14687       DT_TDIFF = -ABS(T)
14688
14689       RETURN
14690
14691  9999 CONTINUE
14692       WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14693  1000 FORMAT(1X,'DT_TDIFF:   t-selection rejected!',/,
14694      &       1X,'ECM  = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14695      &       E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14696       IREJ = 1
14697       RETURN
14698       END
14699
14700 *$ CREATE DT_XVALHM.FOR
14701 *COPY DT_XVALHM
14702 *
14703 *===xvalhm=============================================================*
14704 *
14705       SUBROUTINE DT_XVALHM(KP,KT)
14706
14707 ************************************************************************
14708 * Sampling of parton x-values in high-mass diffractive interactions.   *
14709 * This version dated 12.02.95 is written by S. Roesler                 *
14710 ************************************************************************
14711
14712       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14713       SAVE
14714
14715       PARAMETER ( LINP = 10 ,
14716      &            LOUT = 6 ,
14717      &            LDAT = 9 )
14718
14719       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14720
14721 * kinematics of diffractive interactions (DTUNUC 1.x)
14722       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14723      &                PPF(4),PTF(4),
14724      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14725      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14726
14727 * various options for treatment of partons (DTUNUC 1.x)
14728 * (chain recombination, Cronin,..)
14729       LOGICAL LCO2CR,LINTPT
14730       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14731      &                LCO2CR,LINTPT
14732
14733       DATA UNON,XVQTHR /2.0D0,0.8D0/
14734
14735       IF (KP.EQ.2) THEN
14736 * x-fractions of projectile valence partons
14737     1    CONTINUE
14738          XPH(1) = DT_DBETAR(OHALF,UNON)
14739          IF (XPH(1).GE.XVQTHR) GOTO 1
14740          XPH(2) = ONE-XPH(1)
14741 * x-fractions of Pomeron q-aq-pair
14742          XPOLO = TINY2
14743          XPOHI = ONE-TINY2
14744          XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14745          XPPO(2) = ONE-XPPO(1)
14746 * flavors of Pomeron q-aq-pair
14747          IFLAV    = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14748          IFPPO(1) = IFLAV
14749          IFPPO(2) = -IFLAV
14750          IF (DT_RNDM(UNON).GT.OHALF) THEN
14751             IFPPO(1) = -IFLAV
14752             IFPPO(2) = IFLAV
14753          ENDIF
14754       ENDIF
14755
14756       IF (KT.EQ.2) THEN
14757 * x-fractions of projectile target partons
14758     2    CONTINUE
14759          XTH(1) = DT_DBETAR(OHALF,UNON)
14760          IF (XTH(1).GE.XVQTHR) GOTO 2
14761          XTH(2) = ONE-XTH(1)
14762 * x-fractions of Pomeron q-aq-pair
14763          XPOLO = TINY2
14764          XPOHI = ONE-TINY2
14765          XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14766          XTPO(2) = ONE-XTPO(1)
14767 * flavors of Pomeron q-aq-pair
14768          IFLAV    = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14769          IFTPO(1) = IFLAV
14770          IFTPO(2) = -IFLAV
14771          IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14772             IFTPO(1) = -IFLAV
14773             IFTPO(2) = IFLAV
14774          ENDIF
14775       ENDIF
14776
14777       RETURN
14778       END
14779
14780 *$ CREATE DT_LM2RES.FOR
14781 *COPY DT_LM2RES
14782 *
14783 *===lm2res=============================================================*
14784 *
14785       SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14786
14787 ************************************************************************
14788 * Check low-mass diffractive excitation for resonance mass.            *
14789 *   (input)   IF1/2    PDG-indizes of valence partons                  *
14790 *   (in/out)  XM       diffractive mass requested/corrected            *
14791 *   (output)  IDR/IDXR id./BAMJET-index of resonance                   *
14792 * This version dated 12.02.95 is written by S. Roesler                 *
14793 ************************************************************************
14794
14795       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14796       SAVE
14797
14798       PARAMETER ( LINP = 10 ,
14799      &            LOUT = 6 ,
14800      &            LDAT = 9 )
14801
14802       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14803
14804 * kinematics of diffractive interactions (DTUNUC 1.x)
14805       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14806      &                PPF(4),PTF(4),
14807      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14808      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14809
14810       IREJ = 0
14811       IF1B = 0
14812       IF2B = 0
14813       XMI  = XM
14814
14815 * BAMJET indices of partons
14816       IF1A = IDT_IPDG2B(IF1,1,2)
14817       IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14818       IF2A = IDT_IPDG2B(IF2,1,2)
14819       IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14820
14821 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14822       IDCH = 2
14823       IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14824
14825 * check for resonance mass
14826       CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14827       IF (IREJ1.NE.0) GOTO 9999
14828
14829       XM = XMN
14830       RETURN
14831
14832  9999 CONTINUE
14833       IREJ = 1
14834       RETURN
14835       END
14836
14837 *$ CREATE DT_LMKINE.FOR
14838 *COPY DT_LMKINE
14839 *
14840 *===lmkine=============================================================*
14841 *
14842       SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14843
14844 ************************************************************************
14845 * Kinematical treatment of low-mass excitations.                       *
14846 * This version dated 12.02.95 is written by S. Roesler                 *
14847 ************************************************************************
14848
14849       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14850       SAVE
14851
14852       PARAMETER ( LINP = 10 ,
14853      &            LOUT = 6 ,
14854      &            LDAT = 9 )
14855
14856       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14857
14858 * flags for input different options
14859       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14860       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14861      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14862
14863 * kinematics of diffractive interactions (DTUNUC 1.x)
14864       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14865      &                PPF(4),PTF(4),
14866      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14867      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14868
14869       DIMENSION P1(4),P2(4)
14870
14871       IREJ = 0
14872
14873       IF (KP.EQ.1) THEN
14874          PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14875          POE  = PPF(4)/PABS
14876          FAC1 = OHALF*(POE+ONE)
14877          FAC2 = -OHALF*(POE-ONE)
14878          DO 1 K=1,3
14879             PPLM1(K) = FAC1*PPF(K)
14880             PPLM2(K) = FAC2*PPF(K)
14881     1    CONTINUE
14882          PPLM1(4) = FAC1*PABS
14883          PPLM2(4) = -FAC2*PABS
14884          IF (IMSHL.EQ.1) THEN
14885
14886             XM1 = PYMASS(IFP1)
14887             XM2 = PYMASS(IFP2)
14888
14889             CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14890             IF (IREJ1.NE.0) GOTO 9999
14891             DO 2 K=1,4
14892                PPLM1(K) = P1(K)
14893                PPLM2(K) = P2(K)
14894     2       CONTINUE
14895          ENDIF
14896       ENDIF
14897
14898       IF (KT.EQ.1) THEN
14899          PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14900          POE  = PTF(4)/PABS
14901          FAC1 = OHALF*(POE+ONE)
14902          FAC2 = -OHALF*(POE-ONE)
14903          DO 3 K=1,3
14904             PTLM2(K) = FAC1*PTF(K)
14905             PTLM1(K) = FAC2*PTF(K)
14906     3    CONTINUE
14907          PTLM2(4) = FAC1*PABS
14908          PTLM1(4) = -FAC2*PABS
14909          IF (IMSHL.EQ.1) THEN
14910
14911             XM1 = PYMASS(IFT1)
14912             XM2 = PYMASS(IFT2)
14913
14914             CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14915             IF (IREJ1.NE.0) GOTO 9999
14916             DO 4 K=1,4
14917                PTLM1(K) = P1(K)
14918                PTLM2(K) = P2(K)
14919     4       CONTINUE
14920          ENDIF
14921       ENDIF
14922
14923       RETURN
14924
14925  9999 CONTINUE
14926       WRITE(LOUT,'(A)') 'LMKINE:   kinematical treatment rejected'
14927       IREJ = 1
14928       RETURN
14929       END
14930
14931 *$ CREATE DT_DIFINI.FOR
14932 *COPY DT_DIFINI
14933 *
14934 *===difini=============================================================*
14935 *
14936       SUBROUTINE DT_DIFINI
14937
14938 ************************************************************************
14939 * Initialization of common /DTDIKI/                                    *
14940 * This version dated 12.02.95 is written by S. Roesler                 *
14941 ************************************************************************
14942
14943       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14944       SAVE
14945
14946       PARAMETER ( LINP = 10 ,
14947      &            LOUT = 6 ,
14948      &            LDAT = 9 )
14949
14950       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14951
14952 * kinematics of diffractive interactions (DTUNUC 1.x)
14953       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14954      &                PPF(4),PTF(4),
14955      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14956      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14957
14958       DO 1 K=1,4
14959          PPOM(K)  = ZERO
14960          PSC(K)   = ZERO
14961          PPF(K)   = ZERO
14962          PTF(K)   = ZERO
14963          PPLM1(K) = ZERO
14964          PPLM2(K) = ZERO
14965          PTLM1(K) = ZERO
14966          PTLM2(K) = ZERO
14967     1 CONTINUE
14968       DO 2 K=1,2
14969          XPH(K)   = ZERO
14970          XPPO(K)  = ZERO
14971          XTH(K)   = ZERO
14972          XTPO(K)  = ZERO
14973          IFPPO(K) = 0
14974          IFTPO(K) = 0
14975     2 CONTINUE
14976       IDPR  = 0
14977       IDXPR = 0
14978       IDTR  = 0
14979       IDXTR = 0
14980
14981       RETURN
14982       END
14983
14984 *$ CREATE DT_DIFPUT.FOR
14985 *COPY DT_DIFPUT
14986 *
14987 *===difput=============================================================*
14988 *
14989       SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14990      &                                                          IREJ)
14991
14992 ************************************************************************
14993 * Dump diffractive chains into DTEVT1                                  *
14994 * This version dated 12.02.95 is written by S. Roesler                 *
14995 ************************************************************************
14996
14997       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14998       SAVE
14999
15000       PARAMETER ( LINP = 10 ,
15001      &            LOUT = 6 ,
15002      &            LDAT = 9 )
15003
15004       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
15005
15006       LOGICAL LCHK
15007
15008 * kinematics of diffractive interactions (DTUNUC 1.x)
15009       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
15010      &                PPF(4),PTF(4),
15011      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
15012      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
15013
15014 * event history
15015
15016       PARAMETER (NMXHKK=200000)
15017
15018       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15019      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15020      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15021
15022 * extended event history
15023       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15024      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15025      &                IHIST(2,NMXHKK)
15026
15027 * rejection counter
15028       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
15029      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
15030      &                IREXCI(3),IRDIFF(2),IRINC
15031
15032       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
15033      &          P1(4),P2(4),P3(4),P4(4)
15034
15035       IREJ = 0
15036
15037       IF (KP.EQ.1) THEN
15038          DO 1 K=1,4
15039             PCH(K) = PPLM1(K)+PPLM2(K)
15040     1    CONTINUE
15041          ID1 = IFP1
15042          ID2 = IFP2
15043          IF (DT_RNDM(PT).GT.OHALF) THEN
15044             ID1 = IFP2
15045             ID2 = IFP1
15046          ENDIF
15047          CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
15048      &                                        PPLM1(4),0,0,0)
15049          CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
15050      &                                        PPLM2(4),0,0,0)
15051          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15052      &                                              IDPR,IDXPR,8)
15053       ELSEIF (KP.EQ.2) THEN
15054          DO 2 K=1,4
15055             PP1(K) = XPH(1)*PP(K)
15056             PP2(K) = XPH(2)*PP(K)
15057             PT1(K) = -XPPO(1)*PPOM(K)
15058             PT2(K) = -XPPO(2)*PPOM(K)
15059     2    CONTINUE
15060          CALL  DT_CHKCSY(IFP1,IFPPO(1),LCHK)
15061          XM1 = ZERO
15062          XM2 = ZERO
15063          IF (LCHK) THEN
15064             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15065             IF (IREJ1.NE.0) GOTO 9999
15066             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15067             IF (IREJ1.NE.0) GOTO 9999
15068             DO 3 K=1,4
15069                PP1(K) = P1(K)
15070                PT1(K) = P2(K)
15071                PP2(K) = P3(K)
15072                PT2(K) = P4(K)
15073     3       CONTINUE
15074             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15075      &                                                       0,0,8)
15076             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15077      &                                             PT1(4),0,0,8)
15078             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15079      &                                                       0,0,8)
15080             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15081      &                                             PT2(4),0,0,8)
15082          ELSE
15083             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15084             IF (IREJ1.NE.0) GOTO 9999
15085             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15086             IF (IREJ1.NE.0) GOTO 9999
15087             DO 4 K=1,4
15088                PP1(K) = P1(K)
15089                PT2(K) = P2(K)
15090                PP2(K) = P3(K)
15091                PT1(K) = P4(K)
15092     4       CONTINUE
15093             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15094      &                                                       0,0,8)
15095             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15096      &                                                PT2(4),0,0,8)
15097             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15098      &                                                       0,0,8)
15099             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15100      &                                                PT1(4),0,0,8)
15101          ENDIF
15102          NCSY = NCSY+1
15103       ELSE
15104          CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
15105      &                                                        0,0,0)
15106       ENDIF
15107
15108       IF (KT.EQ.1) THEN
15109          DO 5 K=1,4
15110             PCH(K) = PTLM1(K)+PTLM2(K)
15111     5    CONTINUE
15112          ID1 = IFT1
15113          ID2 = IFT2
15114          IF (DT_RNDM(PT).GT.OHALF) THEN
15115             ID1 = IFT2
15116             ID2 = IFT1
15117          ENDIF
15118          CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
15119      &                                              PTLM1(4),0,0,0)
15120          CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
15121      &                                              PTLM2(4),0,0,0)
15122          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15123      &                                              IDTR,IDXTR,8)
15124       ELSEIF (KT.EQ.2) THEN
15125          DO 6 K=1,4
15126             PP1(K) = XTPO(1)*PPOM(K)
15127             PP2(K) = XTPO(2)*PPOM(K)
15128             PT1(K) = XTH(2)*PT(K)
15129             PT2(K) = XTH(1)*PT(K)
15130     6    CONTINUE
15131          CALL  DT_CHKCSY(IFTPO(1),IFT1,LCHK)
15132          XM1 = ZERO
15133          XM2 = ZERO
15134          IF (LCHK) THEN
15135             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15136             IF (IREJ1.NE.0) GOTO 9999
15137             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15138             IF (IREJ1.NE.0) GOTO 9999
15139             DO 7 K=1,4
15140                PP1(K) = P1(K)
15141                PT1(K) = P2(K)
15142                PP2(K) = P3(K)
15143                PT2(K) = P4(K)
15144     7       CONTINUE
15145             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15146      &                                                PP1(4),0,0,8)
15147             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15148      &                                                       0,0,8)
15149             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15150      &                                                PP2(4),0,0,8)
15151             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15152      &                                                       0,0,8)
15153          ELSE
15154             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15155             IF (IREJ1.NE.0) GOTO 9999
15156             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15157             IF (IREJ1.NE.0) GOTO 9999
15158             DO 8 K=1,4
15159                PP1(K) = P1(K)
15160                PT2(K) = P2(K)
15161                PP2(K) = P3(K)
15162                PT1(K) = P4(K)
15163     8       CONTINUE
15164             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15165      &                                                PP1(4),0,0,8)
15166             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15167      &                                                       0,0,8)
15168             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15169      &                                                PP2(4),0,0,8)
15170             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15171      &                                                       0,0,8)
15172          ENDIF
15173          NCSY = NCSY+1
15174       ELSE
15175          CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
15176      &                                                        0,0,0)
15177       ENDIF
15178
15179       RETURN
15180
15181  9999 CONTINUE
15182       IRDIFF(2) = IRDIFF(2)+1
15183       IREJ      = 1
15184       RETURN
15185       END
15186 *$ CREATE DT_EVTFRG.FOR
15187 *COPY DT_EVTFRG
15188 *
15189 *===evtfrg=============================================================*
15190 *
15191       SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
15192
15193 ************************************************************************
15194 * Hadronization of chains in DTEVT1.                                   *
15195 *                                                                      *
15196 * Input:                                                               *
15197 *   KMODE = 1   hadronization of PHOJET-chains (id=77xxx)              *
15198 *         = 2   hadronization of DTUNUC-chains (id=88xxx)              *
15199 *   NFRG  if KMODE = 1 : upper index of PHOJET-scatterings to be       *
15200 *                        hadronized with one PYEXEC call               *
15201 *         if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
15202 *                        with one PYEXEC call                          *
15203 * Output:                                                              *
15204 *   NPYMEM      number of entries in JETSET-common after hadronization *
15205 *   IREJ        rejection flag                                         *
15206 *                                                                      *
15207 * This version dated 17.09.00 is written by S. Roesler                 *
15208 ************************************************************************
15209
15210       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15211       SAVE
15212
15213       PARAMETER ( LINP = 10 ,
15214      &            LOUT = 6 ,
15215      &            LDAT = 9 )
15216
15217       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
15218       PARAMETER (ONE=1.0D0,ZERO=0.0D0)
15219
15220       LOGICAL LACCEP
15221
15222       PARAMETER (MXJOIN=200)
15223
15224 * event history
15225
15226       PARAMETER (NMXHKK=200000)
15227
15228       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15229      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15230      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15231
15232 * extended event history
15233       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15234      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15235      &                IHIST(2,NMXHKK)
15236
15237 * flags for input different options
15238       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15239       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15240      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15241
15242 * statistics
15243       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
15244      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
15245      &                ICEVTG(8,0:30)
15246
15247 * flags for diffractive interactions (DTUNUC 1.x)
15248       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
15249
15250 * nucleon-nucleon event-generator
15251       CHARACTER*8 CMODEL
15252       LOGICAL LPHOIN
15253       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
15254 * phojet
15255
15256 C  model switches and parameters
15257       CHARACTER*8 MDLNA
15258       INTEGER ISWMDL,IPAMDL
15259       DOUBLE PRECISION PARMDL
15260       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15261 * jetset
15262
15263       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15264       PARAMETER (MAXLND=4000)
15265       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15266
15267       INTEGER PYK
15268
15269       DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
15270
15271       MODE = KMODE
15272       ISTSTG = 7
15273       IF (MODE.NE.1) ISTSTG = 8
15274       IREJ = 0
15275
15276       IP     = 0
15277       ISH    = 0
15278       INIEMC = 1
15279       NEND   = NHKK
15280       NACCEP = 0
15281       IFRG   = 0
15282       IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
15283       DO 10 I=NPOINT(3),NEND
15284 * sr 14.02.00: seems to be not necessary anymore, commented
15285 C        LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
15286 C    &            ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
15287          LACCEP = .TRUE.
15288 * pick up chains from dtevt1
15289          IDCHK = IDHKK(I)/10000
15290          IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
15291             IF (IDCHK.EQ.7) THEN
15292                IPJE = IDHKK(I)-IDCHK*10000
15293                IF (IPJE.NE.IFRG) THEN
15294                   IFRG = IPJE
15295                   IF (IFRG.GT.NFRG) GOTO 16
15296                ENDIF
15297             ELSE
15298                IPJE = 1
15299                IFRG = IFRG+1
15300                IF (IFRG.GT.NFRG) THEN
15301                   NFRG = -1
15302                   GOTO 16
15303                ENDIF
15304             ENDIF
15305 *   statistics counter
15306 c           IF (IDCH(I).LE.8)
15307 c    &         ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
15308 c           IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
15309 * special treatment for small chains already corrected to hadrons
15310             IF (IDRES(I).NE.0) THEN
15311                IF (IDRES(I).EQ.11) THEN
15312                   ID = IDXRES(I)
15313                ELSE
15314                   ID = IDT_IPDGHA(IDXRES(I))
15315                ENDIF
15316                IF (LEMCCK) THEN
15317                   CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15318      &                              PHKK(4,I),INIEMC,IDUM,IDUM)
15319                   INIEMC = 2
15320                ENDIF
15321                IP = IP+1
15322                IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
15323                P(IP,1) = PHKK(1,I)
15324                P(IP,2) = PHKK(2,I)
15325                P(IP,3) = PHKK(3,I)
15326                P(IP,4) = PHKK(4,I)
15327                P(IP,5) = PHKK(5,I)
15328                K(IP,1) = 1
15329                K(IP,2) = ID
15330                K(IP,3) = 0
15331                K(IP,4) = 0
15332                K(IP,5) = 0
15333                IHIST(2,I) = 10000*IPJE+IP
15334                IF (IHIST(1,I).LE.-100) THEN
15335                   ISH = ISH+1
15336                   IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15337                   ISJOIN(ISH) = I
15338                ENDIF
15339                N = IP
15340                IHISMO(IP) = I
15341             ELSE
15342                IJ  = 0
15343                DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
15344                   IF (LEMCCK) THEN
15345                      CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
15346      &                                   PHKK(4,KK),INIEMC,IDUM,IDUM)
15347                      CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
15348                      INIEMC = 2
15349                   ENDIF
15350                   ID = IDHKK(KK)
15351                   IF (ID.EQ.0) ID = 21
15352 c                  PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
15353 c                  AM0  = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
15354
15355 c                  AMRQ   = PYMASS(ID)
15356
15357 c                  AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
15358 c                  IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
15359 c     &                (ABS(IDIFF).EQ.0)) THEN
15360 cC                    WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
15361 c                     DELTA      = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
15362 c                     PHKK(4,KK) = PHKK(4,KK)+DELTA
15363 c                     PTOT1      = PTOT-DELTA
15364 c                     PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
15365 c                     PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
15366 c                     PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
15367 c                     PHKK(5,KK) = AMRQ
15368 c                  ENDIF
15369                   IP = IP+1
15370                   IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
15371                   P(IP,1) = PHKK(1,KK)
15372                   P(IP,2) = PHKK(2,KK)
15373                   P(IP,3) = PHKK(3,KK)
15374                   P(IP,4) = PHKK(4,KK)
15375                   P(IP,5) = PHKK(5,KK)
15376                   K(IP,1) = 1
15377                   K(IP,2) = ID
15378                   K(IP,3) = 0
15379                   K(IP,4) = 0
15380                   K(IP,5) = 0
15381                   IHIST(2,KK) = 10000*IPJE+IP
15382                   IF (IHIST(1,KK).LE.-100) THEN
15383                      ISH = ISH+1
15384                      IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15385                      ISJOIN(ISH) = KK
15386                   ENDIF
15387                   IJ = IJ+1
15388                   IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
15389                   IJOIN(IJ)  = IP
15390                   IHISMO(IP) = I
15391    11          CONTINUE
15392                N = IP
15393 * join the two-parton system
15394
15395                CALL PYJOIN(IJ,IJOIN)
15396
15397             ENDIF
15398             IDHKK(I) = 99999
15399          ENDIF
15400    10 CONTINUE
15401    16 CONTINUE
15402       N = IP
15403
15404       IF (IP.GT.0) THEN
15405
15406 * final state parton shower
15407          DO 136 NPJE=1,IPJE
15408             IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
15409                IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
15410                   DO 130 K1=1,ISH
15411                      IF (ISJOIN(K1).EQ.0) GOTO 130
15412                      I = ISJOIN(K1)
15413                      IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
15414      &                                                       GOTO 130
15415                      IH1 = IHIST(2,I)/10000
15416                      IF (IH1.NE.NPJE) GOTO 130
15417                      IH1 = IHIST(2,I)-IH1*10000
15418                      DO 135 K2=K1+1,ISH
15419                         IF (ISJOIN(K2).EQ.0) GOTO 135
15420                         II = ISJOIN(K2)
15421                         IH2 = IHIST(2,II)/10000
15422                         IF (IH2.NE.NPJE) GOTO 135
15423                         IH2 = IHIST(2,II)-IH2*10000
15424                         IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
15425                            PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
15426                            PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
15427
15428                            RQLUN = MIN(PT1,PT2)
15429                            CALL PYSHOW(IH1,IH2,RQLUN)
15430
15431                            ISJOIN(K1) = 0
15432                            ISJOIN(K2) = 0
15433                            GOTO 130
15434                         ENDIF
15435  135                 CONTINUE
15436  130              CONTINUE
15437                ENDIF
15438             ENDIF
15439  136     CONTINUE
15440
15441          CALL DT_INITJS(MODE)
15442 * hadronization
15443
15444          CALL PYEXEC
15445
15446          IF (MSTU(24).NE.0) THEN
15447             WRITE(LOUT,*) ' JETSET-reject at event',
15448      &                    NEVHKK,MSTU(24),KMODE
15449 C           CALL DT_EVTOUT(4)
15450
15451 C           CALL PYLIST(2)
15452
15453             GOTO 9999
15454          ENDIF
15455
15456 *   number of entries in LUJETS
15457
15458          NLINES = PYK(0,1)
15459
15460          NPYMEM = NLINES
15461
15462          DO 12 I=1,NLINES
15463             IFLG(I) = 0
15464    12    CONTINUE
15465
15466          DO 13 II=1,NLINES
15467
15468             IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
15469
15470 *  pick up mother resonance if possible and put it together with
15471 *  their decay-products into the common
15472                IDXMOR = K(II,3)
15473                IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
15474                   KFMOR = K(IDXMOR,2)
15475                   ISMOR = K(IDXMOR,1)
15476                ELSE
15477                   KFMOR = 91
15478                   ISMOR = 1
15479                ENDIF
15480                IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
15481      &             (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
15482                   ID = K(IDXMOR,2)
15483                   MO = IHISMO(PYK(IDXMOR,15))
15484                   PX = PYP(IDXMOR,1)
15485                   PY = PYP(IDXMOR,2)
15486                   PZ = PYP(IDXMOR,3)
15487                   PE = PYP(IDXMOR,4)
15488
15489                   CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15490                   IFLG(IDXMOR) = 1
15491                   MO = NHKK
15492                   DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
15493                      IF (PYK(JDAUG,7).EQ.1) THEN
15494                         ID = PYK(JDAUG,8)
15495                         PX = PYP(JDAUG,1)
15496                         PY = PYP(JDAUG,2)
15497                         PZ = PYP(JDAUG,3)
15498                         PE = PYP(JDAUG,4)
15499
15500                         CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15501                         IF (LEMCCK) THEN
15502                            PX = -PYP(JDAUG,1)
15503                            PY = -PYP(JDAUG,2)
15504                            PZ = -PYP(JDAUG,3)
15505                            PE = -PYP(JDAUG,4)
15506
15507                            CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15508                         ENDIF
15509                         IFLG(JDAUG) = 1
15510                      ENDIF
15511    15             CONTINUE
15512                ELSE
15513 *  there was no mother resonance
15514                   MO = IHISMO(PYK(II,15))
15515                   ID = PYK(II,8)
15516                   PX = PYP(II,1)
15517                   PY = PYP(II,2)
15518                   PZ = PYP(II,3)
15519                   PE = PYP(II,4)
15520
15521                   CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15522                   IF (LEMCCK) THEN
15523                      PX = -PYP(II,1)
15524                      PY = -PYP(II,2)
15525                      PZ = -PYP(II,3)
15526                      PE = -PYP(II,4)
15527
15528                      CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15529                   ENDIF
15530                ENDIF
15531             ENDIF
15532    13    CONTINUE
15533          IF (LEMCCK) THEN
15534             CHKLEV = TINY1
15535             CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
15536 C           IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
15537          ENDIF
15538
15539 * global energy-momentum & flavor conservation check
15540 **sr 16.5. this check is skipped in case of phojet-treatment
15541          IF (MCGENE.EQ.1)
15542      &      CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
15543
15544 * update statistics-counter for diffraction
15545 c        IF (IFLAGD.NE.0) THEN
15546 c           ICDIFF(1) = ICDIFF(1)+1
15547 c           IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
15548 c           IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
15549 c           IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
15550 c           IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
15551 c        ENDIF
15552
15553       ENDIF
15554
15555       RETURN
15556
15557  9999 CONTINUE
15558       IREJ = 1
15559       RETURN
15560       END
15561
15562 *$ CREATE DT_DECAYS.FOR
15563 *COPY DT_DECAYS
15564 *
15565 *===decay==============================================================*
15566 *
15567       SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15568
15569 ************************************************************************
15570 * Resonance-decay.                                                     *
15571 * This subroutine replaces DDECAY/DECHKK.                              *
15572 *             PIN(4)      4-momentum of resonance          (input)     *
15573 *             IDXIN       BAMJET-index of resonance        (input)     *
15574 *             POUT(20,4)  4-momenta of decay-products      (output)    *
15575 *             IDXOUT(20)  BAMJET-indices of decay-products (output)    *
15576 *             NSEC        number of secondaries            (output)    *
15577 * Adopted from the original version DECHKK.                            *
15578 * This version dated 09.01.95 is written by S. Roesler                 *
15579 ************************************************************************
15580
15581       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15582       SAVE
15583
15584       PARAMETER ( LINP = 10 ,
15585      &            LOUT = 6 ,
15586      &            LDAT = 9 )
15587
15588       PARAMETER (TINY17=1.0D-17)
15589
15590 * HADRIN: decay channel information
15591       PARAMETER (IDMAX9=602)
15592       CHARACTER*8 ZKNAME
15593       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15594
15595 * particle properties (BAMJET index convention)
15596       CHARACTER*8  ANAME
15597       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15598      &                IICH(210),IIBAR(210),K1(210),K2(210)
15599
15600 * flags for input different options
15601       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15602       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15603      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15604
15605       DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
15606      &          EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
15607      &          CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
15608
15609 * ISTAB = 1 strong and weak decays
15610 *       = 2 strong decays only
15611 *       = 3 strong decays, weak decays for charmed particles and tau
15612 *           leptons only
15613       DATA ISTAB /2/
15614
15615       IREJ = 0
15616       NSEC = 0
15617 * put initial resonance to stack
15618       NSTK = 1
15619       IDXSTK(NSTK) = IDXIN
15620       DO 5 I=1,4
15621          PI(NSTK,I) = PIN(I)
15622     5 CONTINUE
15623
15624 * store initial configuration for energy-momentum cons. check
15625       IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
15626      &                                   PI(NSTK,4),1,IDUM,IDUM)
15627
15628   100 CONTINUE
15629 * get particle from stack
15630       IDXI = IDXSTK(NSTK)
15631 * skip stable particles
15632       IF (ISTAB.EQ.1) THEN
15633          IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
15634          IF ((IDXI.GE.  1).AND.(IDXI.LE.  7)) GOTO 10
15635       ELSEIF (ISTAB.EQ.2) THEN
15636          IF ((IDXI.GE.  1).AND.(IDXI.LE. 30)) GOTO 10
15637          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15638          IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
15639          IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
15640          IF ( IDXI.EQ.109)                    GOTO 10
15641          IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
15642       ELSEIF (ISTAB.EQ.3) THEN
15643          IF ((IDXI.GE.  1).AND.(IDXI.LE. 23)) GOTO 10
15644          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15645          IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
15646          IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
15647       ENDIF
15648
15649 * calculate direction cosines and Lorentz-parameter of decaying part.
15650       PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
15651       PTOT = MAX(PTOT,TINY17)
15652       DO 1 I=1,3
15653          DCOS(I) = PI(NSTK,I)/PTOT
15654     1 CONTINUE
15655       GAM  = PI(NSTK,4)/AAM(IDXI)
15656       BGAM = PTOT/AAM(IDXI)
15657
15658 * get decay-channel
15659       KCHAN = K1(IDXI)-1
15660     2 CONTINUE
15661       KCHAN = KCHAN+1
15662       IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
15663
15664 * identities of secondaries
15665       IDX(1) = NZK(KCHAN,1)
15666       IDX(2) = NZK(KCHAN,2)
15667       IF (IDX(2).LT.1) GOTO 9999
15668       IDX(3) = NZK(KCHAN,3)
15669
15670 * handle decay in rest system of decaying particle
15671       IF (IDX(3).EQ.0) THEN
15672 *   two-particle decay
15673          NDEC = 2
15674          CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
15675      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15676      &               AAM(IDX(1)),AAM(IDX(2)))
15677       ELSE
15678 *   three-particle decay
15679          NDEC = 3
15680          CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
15681      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15682      &               CODF(3),COFF(3),SIFF(3),
15683      &               AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15684       ENDIF
15685       NSTK = NSTK-1
15686
15687 * transform decay products back
15688       DO 3 I=1,NDEC
15689          NSTK = NSTK+1
15690          CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15691      &               CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15692      &               PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15693 * add particle to stack
15694          IDXSTK(NSTK) = IDX(I)
15695          DO 4 J=1,3
15696             PI(NSTK,J) = DCOSF(J)*PFF(I)
15697     4    CONTINUE
15698     3 CONTINUE
15699       GOTO 100
15700
15701    10 CONTINUE
15702 * stable particle, put to output-arrays
15703       NSEC = NSEC+1
15704       DO 6 I=1,4
15705          POUT(NSEC,I) = PI(NSTK,I)
15706     6 CONTINUE
15707       IDXOUT(NSEC) = IDXSTK(NSTK)
15708 * store secondaries for energy-momentum conservation check
15709       IF (LEMCCK)
15710      &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15711      &            -POUT(NSEC,4),2,IDUM,IDUM)
15712       NSTK = NSTK-1
15713       IF (NSTK.GT.0) GOTO 100
15714
15715 * check energy-momentum conservation
15716       IF (LEMCCK) THEN
15717          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15718          IF (IREJ1.NE.0) GOTO 9999
15719       ENDIF
15720
15721       RETURN
15722
15723  9999 CONTINUE
15724       IREJ = 1
15725       RETURN
15726       END
15727
15728 *$ CREATE DT_DECAY1.FOR
15729 *COPY DT_DECAY1
15730 *
15731 *===decay1=============================================================*
15732 *
15733       SUBROUTINE DT_DECAY1
15734
15735 ************************************************************************
15736 * Decay of resonances stored in DTEVT1.                                *
15737 * This version dated 20.01.95 is written by S. Roesler                 *
15738 ************************************************************************
15739
15740       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15741       SAVE
15742
15743       PARAMETER ( LINP = 10 ,
15744      &            LOUT = 6 ,
15745      &            LDAT = 9 )
15746
15747 * event history
15748
15749       PARAMETER (NMXHKK=200000)
15750
15751       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15752      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15753      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15754
15755 * extended event history
15756       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15757      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15758      &                IHIST(2,NMXHKK)
15759
15760       DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15761
15762       NEND = NHKK
15763 C     DO 1 I=NPOINT(5),NEND
15764       DO 1 I=NPOINT(4),NEND
15765          IF (ABS(ISTHKK(I)).EQ.1) THEN
15766             DO 2 K=1,4
15767                PIN(K) = PHKK(K,I)
15768     2       CONTINUE
15769             IDXIN = IDBAM(I)
15770             CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15771             IF (NSEC.GT.1) THEN
15772                DO 3 N=1,NSEC
15773                   IDHAD = IDT_IPDGHA(IDXOUT(N))
15774                   CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15775      &                               POUT(N,3),POUT(N,4),0,0,0)
15776     3          CONTINUE
15777             ENDIF
15778          ENDIF
15779     1 CONTINUE
15780
15781       RETURN
15782       END
15783
15784 *$ CREATE DT_DECPI0.FOR
15785 *COPY DT_DECPI0
15786 *
15787 *===decpi0=============================================================*
15788 *
15789       SUBROUTINE DT_DECPI0
15790
15791 ************************************************************************
15792 * Decay of pi0 handled with JETSET.                                    *
15793 * This version dated 18.02.96 is written by S. Roesler                 *
15794 ************************************************************************
15795
15796       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15797       SAVE
15798
15799       PARAMETER ( LINP = 10 ,
15800      &            LOUT = 6 ,
15801      &            LDAT = 9 )
15802
15803       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15804
15805 * event history
15806
15807       PARAMETER (NMXHKK=200000)
15808
15809       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15810      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15811      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15812
15813 * extended event history
15814       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15815      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15816      &                IHIST(2,NMXHKK)
15817
15818       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15819       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15820       PARAMETER (MAXLND=4000)
15821       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15822
15823 * flags for input different options
15824       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15825       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15826      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15827
15828       INTEGER PYCOMP,PYK
15829
15830       DIMENSION IHISMO(NMXHKK),P1(4)
15831
15832       TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15833
15834       CALL DT_INITJS(2)
15835 * allow pi0 decay
15836
15837       KC = PYCOMP(111)
15838
15839       MDCY(KC,1) = 1
15840
15841       NN  = 0
15842       INI = 0
15843       DO 1 I=1,NHKK
15844          IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15845             IF (INI.EQ.0) THEN
15846                INI = 1
15847             ELSE
15848                INI = 2
15849             ENDIF
15850             IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15851      &                                    PHKK(4,I),INI,IDUM,IDUM)
15852             PT    = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15853             PTOT  = SQRT(PT**2+PHKK(3,I)**2)
15854             COSTH = PHKK(3,I)/(PTOT+TINY10)
15855             IF (COSTH.GT.ONE) THEN
15856                THETA = ZERO
15857             ELSEIF (COSTH.LT.-ONE) THEN
15858                THETA = TWOPI/2.0D0
15859             ELSE
15860                THETA = ACOS(COSTH)
15861             ENDIF
15862             PHI     = ASIN(PHKK(2,I)/(PT  +TINY10))
15863             IF (PHKK(1,I).LT.0.0D0)
15864
15865      &         PHI  = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15866
15867             ENER    = PHKK(4,I)
15868             NN      = NN+1
15869             KTEMP   = MSTU(10)
15870             MSTU(10)= 1
15871             P(NN,5) = PHKK(5,I)
15872
15873             CALL PY1ENT(NN,111,ENER,THETA,PHI)
15874
15875             MSTU(10)  = KTEMP
15876             IHISMO(NN)= I
15877          ENDIF
15878     1 CONTINUE
15879       IF (NN.GT.0) THEN
15880
15881          CALL PYEXEC
15882
15883          NLINES = PYK(0,1)
15884
15885          DO 2 II=1,NLINES
15886
15887             IF (PYK(II,7).EQ.1) THEN
15888
15889                DO 3 KK=1,4
15890
15891                   P1(KK) = PYP(II,KK)
15892
15893     3          CONTINUE
15894
15895                ID = PYK(II,8)
15896                MO = IHISMO(PYK(II,15))
15897
15898                CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15899                IF (LEMCCK)
15900      &            CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15901      &                                            IDUM,IDUM)
15902 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15903                ISTHKK(MO) = -2
15904             ENDIF
15905     2    CONTINUE
15906          IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15907       ENDIF
15908       MDCY(KC,1) = 0
15909
15910       RETURN
15911       END
15912
15913 *$ CREATE DT_DTWOPD.FOR
15914 *COPY DT_DTWOPD
15915 *
15916 *===dtwopd=============================================================*
15917 *
15918       SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15919      &                                            COF2,SIF2,AM1,AM2)
15920
15921 ************************************************************************
15922 * Two-particle decay.                                                  *
15923 *  UMO                 cm-energy of the decaying system       (input)  *
15924 *  AM1/AM2             masses of the decay products           (input)  *
15925 *  ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15926 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15927 * Revised by S. Roesler, 20.11.95                                      *
15928 ************************************************************************
15929
15930       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15931       SAVE
15932
15933       PARAMETER ( LINP = 10 ,
15934      &            LOUT = 6 ,
15935      &            LDAT = 9 )
15936
15937       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15938
15939       IF (UMO.LT.(AM1+AM2)) THEN
15940          WRITE(LOUT,1000) UMO,AM1,AM2
15941  1000    FORMAT(1X,'DTWOPD:    inconsistent kinematics - UMO,AM1,AM2 ',
15942      &          3E12.3)
15943          STOP
15944       ENDIF
15945
15946       ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15947       ECM2 = UMO-ECM1
15948       PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15949       PCM2 = PCM1
15950       CALL DT_DSFECF(SIF1,COF1)
15951       COD1 = TWO*DT_RNDM(PCM2)-ONE
15952       COD2 = -COD1
15953       COF2 = -COF1
15954       SIF2 = -SIF1
15955
15956       RETURN
15957       END
15958
15959 *$ CREATE DT_DTHREP.FOR
15960 *COPY DT_DTHREP
15961 *
15962 *===dthrep=============================================================*
15963 *
15964       SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15965      &                  SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15966
15967 ************************************************************************
15968 * Three-particle decay.                                                *
15969 *  UMO                 cm-energy of the decaying system       (input)  *
15970 *  AM1/2/3             masses of the decay products           (input)  *
15971 *  ECM1/2/2,PCM1/2/3   cm-energies/momenta of the decay prod. (output) *
15972 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15973 *                                                                      *
15974 * Threpd89: slight revision by A. Ferrari                              *
15975 * Last change on   11-oct-93   by    Alfredo Ferrari, INFN - Milan     *
15976 * Revised by S. Roesler, 20.11.95                                      *
15977 ************************************************************************
15978
15979       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15980       SAVE
15981
15982       PARAMETER ( LINP = 10 ,
15983      &            LOUT = 6 ,
15984      &            LDAT = 9 )
15985
15986       PARAMETER ( ANGLSQ = 2.5D-31 )
15987       PARAMETER ( AZRZRZ = 1.0D-30 )
15988       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
15989       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
15990       PARAMETER ( ONEONE = 1.D+00 )
15991       PARAMETER ( TWOTWO = 2.D+00 )
15992       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15993
15994       COMMON /HNGAMR/ REDU,AMO,AMM(15)
15995
15996 * flags for input different options
15997       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15998       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15999      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16000
16001       DIMENSION F(5),XX(5)
16002       DATA EPS /AZRZRZ/
16003
16004       UMOO=UMO+UMO
16005 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
16006 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
16007 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
16008       UUMO=UMO
16009       AAM1=AM1
16010       AAM2=AM2
16011       AAM3=AM3
16012       GU=(AM2+AM3)**2
16013       GO=(UMO-AM1)**2
16014 *     UFAK=1.0000000000001D0
16015 *     IF (GU.GT.GO) UFAK=0.9999999999999D0
16016       IF (GU.GT.GO) THEN
16017          UFAK=ONEMNS
16018       ELSE
16019          UFAK=ONEPLS
16020       END IF
16021       OFAK=2.D0-UFAK
16022       GU=GU*UFAK
16023       GO=GO*OFAK
16024       DS2=(GO-GU)/99.D0
16025       AM11=AM1*AM1
16026       AM22=AM2*AM2
16027       AM33=AM3*AM3
16028       UMO2=UMO*UMO
16029       RHO2=0.D0
16030       S22=GU
16031       DO 124 I=1,100
16032          S21=S22
16033          S22=GU+(I-1.D0)*DS2
16034          RHO1=RHO2
16035          RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
16036      *                                             (S22+EPS)
16037          IF(RHO2.LT.RHO1) GO TO 125
16038   124 CONTINUE
16039   125 S2SUP=(S22-S21)*.5D0+S21
16040       SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
16041      *                                           (S2SUP+EPS)
16042       SUPRHO=SUPRHO*1.05D0
16043       XO=S21-DS2
16044       IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
16045       IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
16046       XX(1)=XO
16047       XX(3)=S22
16048       X1=(XO+S22)*0.5D0
16049       XX(2)=X1
16050       F(3)=RHO2
16051       F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
16052       F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
16053       DO 126 I=1,16
16054          X4=(XX(1)+XX(2))*0.5D0
16055          X5=(XX(2)+XX(3))*0.5D0
16056          F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
16057      *                                               (X4+EPS)
16058          F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
16059      *                                               (X5+EPS)
16060          XX(4)=X4
16061          XX(5)=X5
16062          DO 128 II=1,5
16063             IA=II
16064             DO 128 III=IA,5
16065                IF (F (II).GE.F (III)) GO TO 128
16066                FH=F(II)
16067                F(II)=F(III)
16068                F(III)=FH
16069                FH=XX(II)
16070                XX(II)=XX(III)
16071                XX(III)=FH
16072 128      CONTINUE
16073          SUPRHO=F(1)
16074          S2SUP=XX(1)
16075          DO 129 II=1,3
16076             IA=II
16077             DO 129 III=IA,3
16078                IF (XX(II).GE.XX(III)) GO TO 129
16079                FH=F(II)
16080                F(II)=F(III)
16081                F(III)=FH
16082                FH=XX(II)
16083                XX(II)=XX(III)
16084                XX(III)=FH
16085 129      CONTINUE
16086 126   CONTINUE
16087       AM23=(AM2+AM3)**2
16088       ITH=0
16089       REDU=2.D0
16090     1 CONTINUE
16091       ITH=ITH+1
16092       IF (ITH.GT.200) REDU=-9.D0
16093       IF (ITH.GT.200) GO TO 400
16094       C=DT_RNDM(REDU)
16095 *     S2=AM23+C*((UMO-AM1)**2-AM23)
16096       S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
16097       Y=DT_RNDM(S2)
16098       Y=Y*SUPRHO
16099       RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
16100       IF(Y.GT.RHO) GO TO 1
16101 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
16102       S1=DT_RNDM(S2)
16103       S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
16104      &RHO*.5D0
16105       S3=UMO2+AM11+AM22+AM33-S1-S2
16106       ECM1=(UMO2+AM11-S2)/UMOO
16107       ECM2=(UMO2+AM22-S3)/UMOO
16108       ECM3=(UMO2+AM33-S1)/UMOO
16109       PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
16110       PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
16111       PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
16112       CALL DT_DSFECF(SFE,CFE)
16113 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
16114 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
16115       PCM12 = PCM1 * PCM2
16116       IF ( PCM12 .LT. ANGLSQ ) GO TO 200
16117       COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
16118       GO TO 300
16119  200  CONTINUE
16120          UW=DT_RNDM(S1)
16121          COSTH=(UW-0.5D+00)*2.D+00
16122  300  CONTINUE
16123 *     IF(ABS(COSTH).GT.0.9999999999999999D0)
16124 *    &COSTH=SIGN(0.9999999999999999D0,COSTH)
16125       IF(ABS(COSTH).GT.ONEONE)
16126      &COSTH=SIGN(ONEONE,COSTH)
16127       IF (REDU.LT.1.D+00) RETURN
16128       COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
16129 *     IF(ABS(COSTH2).GT.0.9999999999999999D0)
16130 *    &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
16131       IF(ABS(COSTH2).GT.ONEONE)
16132      &COSTH2=SIGN(ONEONE,COSTH2)
16133       SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
16134       SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
16135       SINTH1=COSTH2*SINTH-COSTH*SINTH2
16136       COSTH1=COSTH*COSTH2+SINTH2*SINTH
16137 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
16138 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
16139 C***THE DIRECTION OF PARTICLE 3
16140 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
16141       CX11=-COSTH1
16142       CY11=SINTH1*CFE
16143       CZ11=SINTH1*SFE
16144       CX22=-COSTH2
16145       CY22=-SINTH2*CFE
16146       CZ22=-SINTH2*SFE
16147       CALL DT_DSFECF(SIF3,COF3)
16148       COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
16149       SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
16150     2 FORMAT(5F20.15)
16151       COD1=CX11*COD3+CZ11*SID3
16152       CHLP=(ONEONE-COD1)*(ONEONE+COD1)
16153       IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
16154      &CX11,CZ11
16155       SID1=SQRT(CHLP)
16156       COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
16157       SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
16158       COD2=CX22*COD3+CZ22*SID3
16159       SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
16160       COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
16161       SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
16162  400  CONTINUE
16163 * === Energy conservation check: === *
16164       EOCHCK = UMO - ECM1 - ECM2 - ECM3
16165 *     SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
16166 *     SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
16167 *     SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
16168       PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
16169       PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
16170      &       + PCM3 * COF3 * SID3
16171       PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
16172      &       + PCM3 * SIF3 * SID3
16173       EOCMPR = 1.D-12 * UMO
16174       IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
16175      &     .GT. EOCMPR ) THEN
16176 **sr 5.5.95 output-unit changed
16177          IF (IOULEV(1).GT.0) THEN
16178             WRITE(LOUT,*)
16179      &      ' *** Threpd: energy/momentum conservation failure! ***',
16180      &      EOCHCK,PXCHCK,PYCHCK,PZCHCK
16181             WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
16182          ENDIF
16183 **
16184       END IF
16185       RETURN
16186       END
16187
16188 *$ CREATE DT_DBKLAS.FOR
16189 *COPY DT_DBKLAS
16190 *
16191 *===dbklas=============================================================*
16192 *
16193       SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
16194
16195       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16196       SAVE
16197
16198       PARAMETER ( LINP = 10 ,
16199      &            LOUT = 6 ,
16200      &            LDAT = 9 )
16201
16202 * quark-content to particle index conversion (DTUNUC 1.x)
16203       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16204      &                IA08(6,21),IA10(6,21)
16205
16206       IF (I) 20,20,10
16207 * baryons
16208    10 CONTINUE
16209       CALL DT_INDEXD(J,K,IND)
16210       I8  = IB08(I,IND)
16211       I10 = IB10(I,IND)
16212       IF (I8.LE.0) I8 = I10
16213       RETURN
16214 * antibaryons
16215    20 CONTINUE
16216       II = IABS(I)
16217       JJ = IABS(J)
16218       KK = IABS(K)
16219       CALL DT_INDEXD(JJ,KK,IND)
16220       I8  = IA08(II,IND)
16221       I10 = IA10(II,IND)
16222       IF (I8.LE.0) I8 = I10
16223
16224       RETURN
16225       END
16226
16227 *$ CREATE DT_INDEXD.FOR
16228 *COPY DT_INDEXD
16229 *
16230 *===indexd=============================================================*
16231 *
16232       SUBROUTINE DT_INDEXD(KA,KB,IND)
16233
16234       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16235       SAVE
16236
16237       PARAMETER ( LINP = 10 ,
16238      &            LOUT = 6 ,
16239      &            LDAT = 9 )
16240
16241       KP = KA*KB
16242       KS = KA+KB
16243       IF (KP.EQ.1) IND=1
16244       IF (KP.EQ.2) IND=2
16245       IF (KP.EQ.3) IND=3
16246       IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
16247       IF (KP.EQ.5) IND=5
16248       IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
16249       IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
16250       IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
16251       IF (KP.EQ.8)  IND=9
16252       IF (KP.EQ.10) IND=10
16253       IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
16254       IF (KP.EQ.9)  IND=12
16255       IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
16256       IF (KP.EQ.15) IND=14
16257       IF (KP.EQ.18) IND=15
16258       IF (KP.EQ.16) IND=16
16259       IF (KP.EQ.20) IND=17
16260       IF (KP.EQ.24) IND=18
16261       IF (KP.EQ.25) IND=19
16262       IF (KP.EQ.30) IND=20
16263       IF (KP.EQ.36) IND=21
16264
16265       RETURN
16266       END
16267
16268 *$ CREATE DT_DCHANT.FOR
16269 *COPY DT_DCHANT
16270 *
16271 *===dchant=============================================================*
16272 *
16273       SUBROUTINE DT_DCHANT
16274
16275       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16276       SAVE
16277
16278       PARAMETER ( LINP = 10 ,
16279      &            LOUT = 6 ,
16280      &            LDAT = 9 )
16281
16282       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16283
16284 * HADRIN: decay channel information
16285       PARAMETER (IDMAX9=602)
16286       CHARACTER*8 ZKNAME
16287       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
16288
16289 * particle properties (BAMJET index convention)
16290       CHARACTER*8  ANAME
16291       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16292      &                IICH(210),IIBAR(210),K1(210),K2(210)
16293
16294       DIMENSION HWT(IDMAX9)
16295
16296 * change of weights wt from absolut values into the sum of wt of a dec.
16297       DO 10 J=1,IDMAX9
16298          HWT(J) = ZERO
16299    10 CONTINUE
16300 C     DO 999 KKK=1,210
16301 C        WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
16302 C    &      ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
16303 C    &      K1(KKK),K2(KKK)
16304 C 999 CONTINUE
16305 C     STOP
16306       DO 30 I=1,210
16307          IK1 = K1(I)
16308          IK2 = K2(I)
16309          HV  = ZERO
16310          DO 20 J=IK1,IK2
16311             HV     = HV+WT(J)
16312             HWT(J) = HV
16313 **sr 13.1.95
16314             IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
16315  1000       FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
16316    20    CONTINUE
16317    30 CONTINUE
16318       DO 40 J=1,IDMAX9
16319          WT(J) = HWT(J)
16320    40 CONTINUE
16321
16322       RETURN
16323       END
16324
16325 *$ CREATE DT_DDATAR.FOR
16326 *COPY DT_DDATAR
16327 *
16328 *===ddatar=============================================================*
16329 *
16330       SUBROUTINE DT_DDATAR
16331
16332       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16333       SAVE
16334
16335       PARAMETER ( LINP = 10 ,
16336      &            LOUT = 6 ,
16337      &            LDAT = 9 )
16338
16339       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16340
16341 * quark-content to particle index conversion (DTUNUC 1.x)
16342       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16343      &                IA08(6,21),IA10(6,21)
16344
16345       DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
16346
16347       DATA IV/ 33, 34, 38,123,  0,  0, 32, 33, 39,124,
16348      &          0,  0, 36, 37, 96,127,  0,  0,126,125,
16349      &        128,129,14*0/
16350       DATA IP/ 23, 14, 16,116,  0,  0, 13, 23, 25,117,
16351      &          0,  0, 15, 24, 31,120,  0,  0,119,118,
16352      &        121,122,14*0/
16353       DATA IB/  0,  1, 21,140,  0,  0,  8, 22,137,  0,
16354      &          0, 97,138,  0,  0,146,  0,  0,  0,  0,
16355      &          0,  1,  8, 22,137,  0,  0,  0, 20,142,
16356      &          0,  0, 98,139,  0,  0,147,  0,  0,  0,
16357      &          0,  0, 21, 22, 97,138,  0,  0, 20, 98,
16358      &        139,  0,  0,  0,145,  0,  0,148,  0,  0,
16359      &          0,  0,  0,140,137,138,146,  0,  0,142,
16360      &        139,147,  0,  0,145,148,           50*0/
16361       DATA IBB/53, 54,104,161,  0,  0, 55,105,162,  0,
16362      &          0,107,164,  0,  0,167,  0,  0,  0,  0,
16363      &          0, 54, 55,105,162,  0,  0, 56,106,163,
16364      &          0,  0,108,165,  0,  0,168,  0,  0,  0,
16365      &          0,  0,104,105,107,164,  0,  0,106,108,
16366      &        165,  0,  0,109,166,  0,  0,169,  0,  0,
16367      &          0,  0,  0,161,162,164,167,  0,  0,163,
16368      &        165,168,  0,  0,166,169,  0,  0,170,47*0/
16369       DATA IA/  0,  2, 99,152,  0,  0,  9,100,149,  0,
16370      &          0,102,150,  0,  0,158,  0,  0,  0,  0,
16371      &          0,  2,  9,100,149,  0,  0,  0,101,154,
16372      &          0,  0,103,151,  0,  0,159,  0,  0,  0,
16373      &          0,  0, 99,100,102,150,  0,  0,101,103,
16374      &        151,  0,  0,  0,157,  0,  0,160,  0,  0,
16375      &          0,  0,  0,152,149,150,158,  0,  0,154,
16376      &        151,159,  0,  0,157,160,           50*0/
16377       DATA IAA/67, 68,110,171,  0,  0, 69,111,172,  0,
16378      &          0,113,174,  0,  0,177,  0,  0,  0,  0,
16379      &          0, 68, 69,111,172,  0,  0, 70,112,173,
16380      &          0,  0,114,175,  0,  0,178,  0,  0,  0,
16381      &          0,  0,110,111,113,174,  0,  0,112,114,
16382      &        175,  0,  0,115,176,  0,  0,179,  0,  0,
16383      &          0,  0,  0,171,172,174,177,  0,  0,173,
16384      &        175,178,  0,  0,176,179,  0,  0,180,47*0/
16385
16386       L=0
16387       DO 2 I=1,6
16388          DO 1 J=1,6
16389             L = L+1
16390             IMPS(I,J) = IP(L)
16391             IMVE(I,J) = IV(L)
16392     1    CONTINUE
16393     2 CONTINUE
16394       L=0
16395       DO 4 I=1,6
16396          DO 3 J=1,21
16397             L = L+1
16398             IB08(I,J) = IB(L)
16399             IB10(I,J) = IBB(L)
16400             IA08(I,J) = IA(L)
16401             IA10(I,J) = IAA(L)
16402     3    CONTINUE
16403     4 CONTINUE
16404 C     A1  = 0.88D0
16405 C     B1  = 3.0D0
16406 C     B2  = 3.0D0
16407 C     B3  = 8.0D0
16408 C     LT  = 0
16409 C     LB  = 0
16410 C     BET = 12.0D0
16411 C     AS  = 0.25D0
16412 C     B8  = 0.33D0
16413 C     AME = 0.95D0
16414 C     DIQ = 0.375D0
16415 C     ISU = 4
16416
16417       RETURN
16418       END
16419
16420 *$ CREATE DT_INITJS.FOR
16421 *COPY DT_INITJS
16422 *
16423 *===initjs=============================================================*
16424 *
16425       SUBROUTINE DT_INITJS(MODE)
16426
16427 ************************************************************************
16428 * Initialize JETSET paramters.                                         *
16429 *           MODE = 0 default settings                                  *
16430 *                = 1 PHOJET settings                                   *
16431 *                = 2 DTUNUC settings                                   *
16432 * This version dated 16.02.96 is written by S. Roesler                 *
16433 *                                                                      *
16434 * Last change 27.12.2006 by S. Roesler.                                *
16435 ************************************************************************
16436
16437       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16438       SAVE
16439
16440       PARAMETER ( LINP = 10 ,
16441      &            LOUT = 6 ,
16442      &            LDAT = 9 )
16443
16444       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16445
16446       LOGICAL LFIRST,LFIRDT,LFIRPH
16447
16448 *      INCLUDE '(DIMPAR)'
16449 *     DIMPAR taken from FLUKA
16450       PARAMETER ( MXXRGN =20000 )
16451       PARAMETER ( MXXMDF =  710 )
16452       PARAMETER ( MXXMDE =  702 )
16453       PARAMETER ( MFSTCK =40000 )
16454       PARAMETER ( MESTCK =  100 )
16455       PARAMETER ( MOSTCK = 2000 )
16456       PARAMETER ( MXPRSN =  100 )
16457       PARAMETER ( MXPDPM =  800 )
16458       PARAMETER ( MXPSCS =30000 )
16459       PARAMETER ( MXGLWN =  300 )
16460       PARAMETER ( MXOUTU =   50 )
16461       PARAMETER ( NALLWP =   64 )
16462       PARAMETER ( NELEMX =   80 )
16463       PARAMETER ( MPDPDX =   18 )
16464       PARAMETER ( MXHTTR =  260 )
16465       PARAMETER ( MXSEAX =   20 )
16466       PARAMETER ( MXHTNC = MXSEAX + 1 )
16467       PARAMETER ( ICOMAX = 2400 )
16468       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
16469       PARAMETER ( NSTBIS =  304 )
16470       PARAMETER ( NQSTIS =   46 )
16471       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
16472       PARAMETER ( MXPABL =  120 )
16473       PARAMETER ( IDMAXP =  450 )
16474       PARAMETER ( IDMXDC = 2000 )
16475       PARAMETER ( MXMCIN =  410 )
16476       PARAMETER ( IHYPMX =    4 )
16477       PARAMETER ( MKBMX1 =   11 )
16478       PARAMETER ( MKBMX2 =   11 )
16479       PARAMETER ( MXIRRD = 2500 )
16480       PARAMETER ( MXTRDC = 1500 )
16481       PARAMETER ( NKTL   =   17 )
16482       PARAMETER ( NBLNMX = 40000000 )
16483
16484 *      INCLUDE '(PART)'
16485 *     PART taken from FLUKA
16486       PARAMETER ( KPETA0 =  31 )
16487       PARAMETER ( KPRHOP =  32 )
16488       PARAMETER ( KPRHO0 =  33 )
16489       PARAMETER ( KPRHOM =  34 )
16490       PARAMETER ( KPOME0 =  35 )
16491       PARAMETER ( KPPHI0 =  96 )
16492       PARAMETER ( KPDEPP =  53 )
16493       PARAMETER ( KPDELP =  54 )
16494       PARAMETER ( KPDEL0 =  55 )
16495       PARAMETER ( KPDELM =  56 )
16496       PARAMETER ( KPN14P =  91 )
16497       PARAMETER ( KPN140 =  92 )
16498 *  Low mass diffraction partners:
16499       PARAMETER ( KDETA0 =   0 )
16500       PARAMETER ( KDRHOP =   0 )
16501       PARAMETER ( KDRHO0 = 210 )
16502       PARAMETER ( KDRHOM =   0 )
16503       PARAMETER ( KDOME0 = 210 )
16504       PARAMETER ( KDPHI0 = 210 )
16505       PARAMETER ( KDDEPP =   0 )
16506       PARAMETER ( KDDELP =   0 )
16507       PARAMETER ( KDDEL0 =   0 )
16508       PARAMETER ( KDDELM =   0 )
16509       PARAMETER ( KDN14P =   0 )
16510       PARAMETER ( KDN140 =   0 )
16511 *
16512       CHARACTER*8  ANAME
16513       COMMON / PART /  AM     (-6:IDMAXP), GA     (-6:IDMAXP),
16514      &                 TAU    (-6:IDMAXP), AMDISC (-6:IDMAXP),
16515      &                 ZMNABS (-6:IDMAXP), ATNMNA (-6:IDMAXP),
16516      &                 ATXN14,     ATMN14, RNRN14    (-10:10),
16517      &                 ICH    (-6:IDMAXP), IBAR   (-6:IDMAXP),
16518      &                 ISOSYM (-6:IDMAXP), ICHCON (-6:IDMAXP),
16519      &                 K1     (-6:IDMAXP), K2     (-6:IDMAXP),
16520      &                 KPTOIP (-6:IDMAXP), IPTOKP (-6:NALLWP),
16521      &                 KPTOIA (-6:IDMAXP), IATOKP (-6:MXPABL),
16522      &                 IDCFLG (-6:NALLWP), IPTYPE (-6:NALLWP)
16523
16524       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16525       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16526       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16527
16528 * flags for particle decays
16529       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
16530      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
16531      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
16532
16533 * flags for input different options
16534       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16535       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16536      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16537
16538       INTEGER PYCOMP
16539
16540       DIMENSION IDXSTA(40)
16541       DATA IDXSTA
16542 *          K0s   pi0  lam   alam  sig+  asig+ sig-  asig- tet0  atet0
16543      &  /  310,  111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
16544 *          tet- atet-  om-  aom-   D+    D-    D0    aD0   Ds+   aDs+
16545      &    3312,-3312, 3334,-3334,  411, -411,  421, -421,  431, -431,
16546 *          etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
16547      &     441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
16548 *         Ksic0 aKsic+aKsic0 sig0 asig0
16549      &    4132,-4232,-4132, 3212,-3212, 5*0/
16550
16551       DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
16552
16553       IF (LFIRST) THEN
16554 * save default settings
16555          PDEF1  = PARJ(1)
16556          PDEF2  = PARJ(2)
16557          PDEF3  = PARJ(3)
16558          PDEF5  = PARJ(5)
16559          PDEF6  = PARJ(6)
16560          PDEF7  = PARJ(7)
16561          PDEF18 = PARJ(18)
16562          PDEF19 = PARJ(19)
16563          PDEF21 = PARJ(21)
16564          PDEF42 = PARJ(42)
16565          MDEF12 = MSTJ(12)
16566 * LUJETS / PYJETS array-dimensions
16567
16568          MSTU(4) = 4000
16569
16570 * increase maximum number of JETSET-error prints
16571          MSTU(22) = 50000
16572 * prevent particles decaying
16573          DO 1 I=1,35
16574             IF (I.LT.34) THEN
16575
16576                KC = PYCOMP(IDXSTA(I))
16577
16578                IF (KC.GT.0) THEN
16579                   IF (I.EQ.2) THEN
16580 *  pi0 decay
16581 C                    MDCY(KC,1) = 1
16582                      MDCY(KC,1) = 0
16583 **cr mode
16584 C                 ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
16585 C   &                    (I.EQ.8).OR.(I.EQ.10)) THEN
16586 C                 ELSEIF (I.EQ.4) THEN
16587 C                    MDCY(KC,1) = 1
16588 **
16589                   ELSE
16590                      MDCY(KC,1) = 0
16591                   ENDIF
16592                ENDIF
16593             ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
16594
16595                KC = PYCOMP(IDXSTA(I))
16596
16597                IF (KC.GT.0) THEN
16598                   MDCY(KC,1) = 0
16599                ENDIF
16600             ENDIF
16601     1    CONTINUE
16602 *
16603
16604 * as Fluka event-generator: allow only paprop particles to be stable
16605 * and let all other particles decay (i.e. those with strong decays)
16606          IF (ITRSPT.EQ.1) THEN
16607             DO 5 I=1,IDMAXP
16608                IF (KPTOIP(I).NE.0) THEN
16609                   IDPDG = MPDGHA(I)
16610
16611                   KC    = PYCOMP(IDPDG)
16612
16613                   IF (KC.GT.0) THEN
16614                      IF (MDCY(KC,1).EQ.1) THEN
16615                         WRITE(LOUT,*)
16616      &                     ' DT_INITJS: Decay flag for FLUKA-',
16617      &                     'transport : particle should not ',
16618      &                     'decay : ',IDPDG,'  ',ANAME(I)
16619                         MDCY(KC,1) = 0
16620                      ENDIF
16621                   ENDIF
16622                ENDIF
16623     5       CONTINUE
16624             DO 6 KC=1,500
16625                IDPDG = KCHG(KC,4)
16626                KP    = MCIHAD(IDPDG)
16627                IF (KP.GT.0) THEN
16628                   IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND.
16629      &                (ANAME(KP).NE.'BLANK   ').AND.
16630      &                (ANAME(KP).NE.'RNDFLV  ')) THEN
16631                      WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
16632      &                             'transport: particle should decay ',
16633      &                             ': ',IDPDG,' ',ANAME(KP)
16634                      MDCY(KC,1) = 1
16635                   ENDIF
16636                ENDIF
16637     6       CONTINUE
16638          ENDIF
16639
16640 *
16641 * popcorn:
16642          IF (PDB.LE.ZERO) THEN
16643 *   no popcorn-mechanism
16644             MSTJ(12) = 1
16645          ELSE
16646             MSTJ(12) = 3
16647             PARJ(5)  = PDB
16648          ENDIF
16649 * set JETSET-parameter requested by input cards
16650          IF (NMSTU.GT.0) THEN
16651             DO 2 I=1,NMSTU
16652                MSTU(IMSTU(I)) = MSTUX(I)
16653     2       CONTINUE
16654          ENDIF
16655          IF (NMSTJ.GT.0) THEN
16656             DO 3 I=1,NMSTJ
16657                MSTJ(IMSTJ(I)) = MSTJX(I)
16658     3       CONTINUE
16659          ENDIF
16660          IF (NPARU.GT.0) THEN
16661             DO 4 I=1,NPARU
16662                PARU(IPARU(I)) = PARUX(I)
16663     4       CONTINUE
16664          ENDIF
16665          LFIRST = .FALSE.
16666       ENDIF
16667 *
16668 * PARJ(1)  suppression of qq-aqaq pair prod. compared to
16669 *          q-aq pair prod.                      (default: 0.1)
16670 * PARJ(2)  strangeness suppression               (default: 0.3)
16671 * PARJ(3)  extra suppression of strange diquarks (default: 0.4)
16672 * PARJ(6)  extra suppression of sas-pair shared by B and
16673 *          aB in BMaB                           (default: 0.5)
16674 * PARJ(7)  extra suppression of strange meson M in BMaB
16675 *          configuration                        (default: 0.5)
16676 * PARJ(18) spin 3/2 baryon suppression           (default: 1.0)
16677 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
16678 *          momentum distrib. for prim. hadrons  (default: 0.35)
16679 * PARJ(42) b-parameter for symmetric Lund-fragmentation
16680 *          function                             (default: 0.9 GeV^-2)
16681 *
16682 * PHOJET settings
16683       IF (MODE.EQ.1) THEN
16684 *   JETSET default
16685 C        PARJ(1)  = PDEF1
16686 C        PARJ(2)  = PDEF2
16687 C        PARJ(3)  = PDEF3
16688 C        PARJ(6)  = PDEF6
16689 C        PARJ(7)  = PDEF7
16690 C        PARJ(18) = PDEF18
16691 C        PARJ(21) = PDEF21
16692 C        PARJ(42) = PDEF42
16693 **sr 18.11.98 parameter tuning
16694 C        PARJ(1)  = 0.092D0
16695 C        PARJ(2)  = 0.25D0
16696 C        PARJ(3)  = 0.45D0
16697 C        PARJ(19) = 0.3D0
16698 C        PARJ(21) = 0.45D0
16699 C        PARJ(42) = 1.0D0
16700 **sr 28.04.99 parameter tuning (May 99 minor modifications)
16701          PARJ(1)  = 0.085D0
16702          PARJ(2)  = 0.26D0
16703          PARJ(3)  = 0.8D0
16704          PARJ(11) = 0.38D0
16705          PARJ(18) = 0.3D0
16706          PARJ(19) = 0.4D0
16707          PARJ(21) = 0.36D0
16708          PARJ(41) = 0.3D0
16709          PARJ(42) = 0.86D0
16710          IF (NPARJ.GT.0) THEN
16711             DO 10 I=1,NPARJ
16712                IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
16713    10       CONTINUE
16714          ENDIF
16715          IF (LFIRPH) THEN
16716             WRITE(LOUT,'(1X,A)')
16717      &         'DT_INITJS: JETSET-parameter for PHOJET'
16718             CALL DT_JSPARA(0)
16719             LFIRPH = .FALSE.
16720          ENDIF
16721 * DTUNUC settings
16722       ELSEIF (MODE.EQ.2) THEN
16723          IF (IFRAG(2).EQ.1) THEN
16724 **sr parameters before 9.3.96
16725 C           PARJ(2)  = 0.27D0
16726 C           PARJ(3)  = 0.6D0
16727 C           PARJ(6)  = 0.75D0
16728 C           PARJ(7)  = 0.75D0
16729 C           PARJ(21) = 0.55D0
16730 C           PARJ(42) = 1.3D0
16731 **sr 18.11.98 parameter tuning
16732 C           PARJ(1)  = 0.05D0
16733 C           PARJ(2)  = 0.27D0
16734 C           PARJ(3)  = 0.4D0
16735 C           PARJ(19) = 0.2D0
16736 C           PARJ(21) = 0.45D0
16737 C           PARJ(42) = 1.0D0
16738 **sr 28.04.99 parameter tuning
16739             PARJ(1)  = 0.11D0
16740             PARJ(2)  = 0.36D0
16741             PARJ(3)  = 0.8D0
16742             PARJ(19) = 0.2D0
16743             PARJ(21) = 0.3D0
16744             PARJ(41) = 0.3D0
16745             PARJ(42) = 0.58D0
16746             IF (NPARJ.GT.0) THEN
16747                DO 20 I=1,NPARJ
16748                   IF (IPARJ(I).LT.0) THEN
16749                      IDX = ABS(IPARJ(I))
16750                      PARJ(IDX) = PARJX(I)
16751                   ENDIF
16752    20          CONTINUE
16753             ENDIF
16754             IF (LFIRDT) THEN
16755                WRITE(LOUT,'(1X,A)')
16756      &           'DT_INITJS: JETSET-parameter for DTUNUC'
16757                CALL DT_JSPARA(0)
16758                LFIRDT = .FALSE.
16759             ENDIF
16760          ELSEIF (IFRAG(2).EQ.2) THEN
16761             PARJ(1)  = 0.11D0
16762             PARJ(2)  = 0.27D0
16763             PARJ(3)  = 0.3D0
16764             PARJ(6)  = 0.35D0
16765             PARJ(7)  = 0.45D0
16766             PARJ(18) = 0.66D0
16767 C           PARJ(21) = 0.55D0
16768 C           PARJ(42) = 1.0D0
16769             PARJ(21) = 0.60D0
16770             PARJ(42) = 1.3D0
16771          ELSE
16772             PARJ(1)  = PDEF1
16773             PARJ(2)  = PDEF2
16774             PARJ(3)  = PDEF3
16775             PARJ(6)  = PDEF6
16776             PARJ(7)  = PDEF7
16777             PARJ(18) = PDEF18
16778             PARJ(21) = PDEF21
16779             PARJ(42) = PDEF42
16780          ENDIF
16781       ELSE
16782          PARJ(1)  = PDEF1
16783          PARJ(2)  = PDEF2
16784          PARJ(3)  = PDEF3
16785          PARJ(5)  = PDEF5
16786          PARJ(6)  = PDEF6
16787          PARJ(7)  = PDEF7
16788          PARJ(18) = PDEF18
16789          PARJ(19) = PDEF19
16790          PARJ(21) = PDEF21
16791          PARJ(42) = PDEF42
16792          MSTJ(12) = MDEF12
16793       ENDIF
16794
16795       RETURN
16796       END
16797
16798 *$ CREATE DT_JSPARA.FOR
16799 *COPY DT_JSPARA
16800 *
16801 *===jspara=============================================================*
16802 *
16803       SUBROUTINE DT_JSPARA(MODE)
16804
16805       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16806       SAVE
16807
16808       PARAMETER ( LINP = 10 ,
16809      &            LOUT = 6 ,
16810      &            LDAT = 9 )
16811
16812       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
16813      &           ONE=1.0D0,ZERO=0.0D0)
16814
16815       LOGICAL LFIRST
16816
16817       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16818
16819       DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
16820
16821       DATA LFIRST /.TRUE./
16822
16823 * save the default JETSET-parameter on the first call
16824       IF (LFIRST) THEN
16825          DO 1 I=1,200
16826             ISTU(I) = MSTU(I)
16827             QARU(I) = PARU(I)
16828             ISTJ(I) = MSTJ(I)
16829             QARJ(I) = PARJ(I)
16830     1    CONTINUE
16831          LFIRST = .FALSE.
16832       ENDIF
16833
16834       WRITE(LOUT,1000)
16835  1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16836
16837 * compare the default JETSET-parameter with the present values
16838       DO 2 I=1,200
16839          IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16840             WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16841 C           ISTU(I) = MSTU(I)
16842          ENDIF
16843          DIFF = ABS(PARU(I)-QARU(I))
16844          IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16845             WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16846 C           QARU(I) = PARU(I)
16847          ENDIF
16848          IF (MSTJ(I).NE.ISTJ(I)) THEN
16849             WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16850 C           ISTJ(I) = MSTJ(I)
16851          ENDIF
16852          DIFF = ABS(PARJ(I)-QARJ(I))
16853          IF (DIFF.GE.1.0D-5) THEN
16854             WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16855 C           QARJ(I) = PARJ(I)
16856          ENDIF
16857     2 CONTINUE
16858  1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16859  1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16860
16861       RETURN
16862       END
16863 *$ CREATE DT_FOZOCA.FOR
16864 *COPY DT_FOZOCA
16865 *
16866 *===fozoca=============================================================*
16867 *
16868       SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16869
16870 ************************************************************************
16871 * This subroutine treats the complete FOrmation ZOne supressed intra-  *
16872 * nuclear CAscade.                                                     *
16873 *               LFZC = .true.  cascade has been treated                *
16874 *                    = .false. cascade skipped                         *
16875 * This is a completely revised version of the original FOZOKL.         *
16876 * This version dated 18.11.95 is written by S. Roesler                 *
16877 ************************************************************************
16878
16879       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16880       SAVE
16881
16882       PARAMETER ( LINP = 10 ,
16883      &            LOUT = 6 ,
16884      &            LDAT = 9 )
16885
16886       PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16887       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16888
16889       LOGICAL LSTART,LCAS,LFZC
16890
16891 * event history
16892
16893       PARAMETER (NMXHKK=200000)
16894
16895       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16896      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16897      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16898
16899 * extended event history
16900       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16901      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16902      &                IHIST(2,NMXHKK)
16903
16904 * rejection counter
16905       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16906      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16907      &                IREXCI(3),IRDIFF(2),IRINC
16908
16909 * properties of interacting particles
16910       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16911
16912 * Glauber formalism: collision properties
16913       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16914      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16915
16916 * flags for input different options
16917       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16918       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16919      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16920
16921 * final state after intranuclear cascade step
16922       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16923
16924 * parameter for intranuclear cascade
16925       LOGICAL LPAULI
16926       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16927
16928       DIMENSION NCWOUN(2)
16929
16930       DATA LSTART /.TRUE./
16931
16932       LFZC = .TRUE.
16933       IREJ = 0
16934
16935 * skip cascade if hadron-hadron interaction or if supressed by user
16936       IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16937 * skip cascade if not all possible chains systems are hadronized
16938       DO 1 I=1,8
16939          IF (.NOT.LHADRO(I)) GOTO 9999
16940     1 CONTINUE
16941
16942       IF (LSTART) THEN
16943          WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16944  1000    FORMAT(/,1X,'FOZOCA:  intranuclear cascade treated for a ',
16945      &          'maximum of',I4,' generations',/,10X,'formation time ',
16946      &          'parameter:',F5.1,'  fm/c',9X,'modus:',I2)
16947          IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16948          IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16949  1001    FORMAT(10X,'p_t dependent formation zone',/)
16950  1002    FORMAT(10X,'constant formation zone',/)
16951          LSTART = .FALSE.
16952       ENDIF
16953
16954 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16955 * which may interact with final state particles are stored in a seperate
16956 * array - here all proj./target nucleon-indices (just for simplicity)
16957       NOINC = 0
16958       DO 9 I=1,NPOINT(1)-1
16959          NOINC = NOINC+1
16960          IDXINC(NOINC) = I
16961     9 CONTINUE
16962
16963 * initialize Pauli-principle treatment (find wounded nucleons)
16964       NWOUND(1) = 0
16965       NWOUND(2) = 0
16966       NCWOUN(1) = 0
16967       NCWOUN(2) = 0
16968       DO 2 J=1,NPOINT(1)
16969          DO 3 I=1,2
16970             IF (ISTHKK(J).EQ.10+I) THEN
16971                NWOUND(I) = NWOUND(I)+1
16972                EWOUND(I,NWOUND(I)) = PHKK(4,J)
16973                IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16974             ENDIF
16975     3    CONTINUE
16976     2 CONTINUE
16977
16978 * modify nuclear potential for wounded nucleons
16979       IPRCL  = IP -NWOUND(1)
16980       IPZRCL = IPZ-NCWOUN(1)
16981       ITRCL  = IT -NWOUND(2)
16982       ITZRCL = ITZ-NCWOUN(2)
16983       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16984
16985       NSTART = NPOINT(4)
16986       NEND   = NHKK
16987
16988     7 CONTINUE
16989       DO 8 I=NSTART,NEND
16990
16991          IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16992 * select nucleus the cascade starts first (proj. - 1, target - -1)
16993             NCAS   = 1
16994 *   projectile/target with probab. 1/2
16995             IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16996                IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16997 *   in the nucleus with highest mass
16998             ELSEIF (INCMOD.EQ.2) THEN
16999                IF (IP.GT.IT) THEN
17000                   NCAS = -NCAS
17001                ELSEIF (IP.EQ.IT) THEN
17002                   IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
17003                ENDIF
17004 * the nucleus the cascade starts first is requested to be the one
17005 * moving in the direction of the secondary
17006             ELSEIF (INCMOD.EQ.3) THEN
17007                NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
17008             ENDIF
17009 * check that the selected "nucleus" is not a hadron
17010             IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
17011      &          ((NCAS.EQ.-1).AND.(IT.LE.1)))    NCAS = -NCAS
17012
17013 * treat intranuclear cascade in the nucleus selected first
17014             LCAS = .FALSE.
17015             CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17016             IF (IREJ1.NE.0) GOTO 9998
17017 * treat intranuclear cascade in the other nucleus if this isn't a had.
17018             NCAS = -NCAS
17019             IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
17020      &          ((NCAS.EQ.-1).AND.(IT.GT.1)))    THEN
17021                IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17022                IF (IREJ1.NE.0) GOTO 9998
17023             ENDIF
17024
17025          ENDIF
17026
17027     8 CONTINUE
17028       NSTART = NEND+1
17029       NEND   = NHKK
17030       IF (NSTART.LE.NEND) GOTO 7
17031
17032       RETURN
17033
17034  9998 CONTINUE
17035 * reject this event
17036       IRINC = IRINC+1
17037       IREJ = 1
17038
17039  9999 CONTINUE
17040 * intranucl. cascade not treated because of interaction properties or
17041 * it is supressed by user or it was rejected or...
17042       LFZC = .FALSE.
17043 * reset flag characterizing direction of motion in n-n-cms
17044 **sr14-11-95
17045 C     DO 9990 I=NPOINT(5),NHKK
17046 C        IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
17047 C9990 CONTINUE
17048
17049       RETURN
17050       END
17051
17052 *$ CREATE DT_INUCAS.FOR
17053 *COPY DT_INUCAS
17054 *
17055 *===inucas=============================================================*
17056 *
17057       SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
17058
17059 ************************************************************************
17060 * Formation zone supressed IntraNUclear CAScade for one final state    *
17061 * particle.                                                            *
17062 *           IT, IP    mass numbers of target, projectile nuclei        *
17063 *           IDXCAS    index of final state particle in DTEVT1          *
17064 *           NCAS =  1 intranuclear cascade in projectile               *
17065 *                = -1 intranuclear cascade in target                   *
17066 * This version dated 18.11.95 is written by S. Roesler                 *
17067 ************************************************************************
17068
17069       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17070       SAVE
17071
17072       PARAMETER ( LINP = 10 ,
17073      &            LOUT = 6 ,
17074      &            LDAT = 9 )
17075
17076       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
17077      &           OHALF=0.5D0,ONE=1.0D0)
17078       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
17079       PARAMETER (TWOPI=6.283185307179586454D+00)
17080       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
17081
17082       LOGICAL LABSOR,LCAS
17083
17084 * event history
17085
17086       PARAMETER (NMXHKK=200000)
17087
17088       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17089      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17090      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17091
17092 * extended event history
17093       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17094      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17095      &                IHIST(2,NMXHKK)
17096
17097 * final state after inc step
17098       PARAMETER (MAXFSP=10)
17099       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17100
17101 * flags for input different options
17102       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17103       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17104      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17105
17106 * particle properties (BAMJET index convention)
17107       CHARACTER*8  ANAME
17108       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17109      &                IICH(210),IIBAR(210),K1(210),K2(210)
17110
17111 * Glauber formalism: collision properties
17112       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
17113      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
17114
17115 * nuclear potential
17116       LOGICAL LFERMI
17117       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17118      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17119      &                ETACOU(2),ICOUL,LFERMI
17120
17121 * parameter for intranuclear cascade
17122       LOGICAL LPAULI
17123       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17124
17125 * final state after intranuclear cascade step
17126       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
17127
17128 * nucleon-nucleon event-generator
17129       CHARACTER*8 CMODEL
17130       LOGICAL LPHOIN
17131       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
17132
17133 * statistics: residual nuclei
17134       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
17135      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
17136      &                NINCST(2,4),NINCEV(2),
17137      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
17138      &                NRESPB(2),NRESCH(2),NRESEV(4),
17139      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
17140      &                NEVAFI(2,2)
17141
17142       DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
17143      &          PCAS1(5),PNUC(5),BGTA(4),
17144      &          BGCAS(2),GACAS(2),BECAS(2),
17145      &          RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
17146
17147       DATA PDIF /0.545D0/
17148
17149       IREJ = 0
17150
17151 * update counter
17152       IF (NINCEV(1).NE.NEVHKK) THEN
17153          NINCEV(1) = NEVHKK
17154          NINCEV(2) = NINCEV(2)+1
17155       ENDIF
17156
17157 * "BAMJET-index" of this hadron
17158       IDCAS = IDBAM(IDXCAS)
17159       IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
17160
17161 * skip gammas, electrons, etc..
17162       IF (AAM(IDCAS).LT.TINY2) RETURN
17163
17164 * Lorentz-trsf. into projectile rest system
17165       IF (IP.GT.1) THEN
17166          CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17167      &               PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
17168      &               PCAS(1,4),IDCAS,-2)
17169          PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
17170          PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
17171          IF (PCAS(1,5).GT.ZERO) THEN
17172             PCAS(1,5) = SQRT(PCAS(1,5))
17173          ELSE
17174             PCAS(1,5) = AAM(IDCAS)
17175          ENDIF
17176          DO 20 K=1,3
17177             COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
17178    20    CONTINUE
17179 * Lorentz-parameters
17180 *   particle rest system --> projectile rest system
17181          BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
17182          GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
17183          BECAS(1) = BGCAS(1)/GACAS(1)
17184       ELSE
17185          DO 21 K=1,5
17186             PCAS(1,K) = ZERO
17187             IF (K.LE.3) COSCAS(1,K) = ZERO
17188    21    CONTINUE
17189          PTOCAS(1) = ZERO
17190          BGCAS(1)  = ZERO
17191          GACAS(1)  = ZERO
17192          BECAS(1)  = ZERO
17193       ENDIF
17194 * Lorentz-trsf. into target rest system
17195       IF (IT.GT.1) THEN
17196 * LEPTO: final state particles are already in target rest frame
17197 C        IF (MCGENE.EQ.3) THEN
17198 C           PCAS(2,1) = PHKK(1,IDXCAS)
17199 C           PCAS(2,2) = PHKK(2,IDXCAS)
17200 C           PCAS(2,3) = PHKK(3,IDXCAS)
17201 C           PCAS(2,4) = PHKK(4,IDXCAS)
17202 C        ELSE
17203             CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17204      &                  PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
17205      &                  PCAS(2,4),IDCAS,-3)
17206 C        ENDIF
17207          PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
17208          PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
17209          IF (PCAS(2,5).GT.ZERO) THEN
17210             PCAS(2,5) = SQRT(PCAS(2,5))
17211          ELSE
17212             PCAS(2,5) = AAM(IDCAS)
17213          ENDIF
17214          DO 22 K=1,3
17215             COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
17216    22    CONTINUE
17217 * Lorentz-parameters
17218 *   particle rest system --> target rest system
17219          BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
17220          GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
17221          BECAS(2) = BGCAS(2)/GACAS(2)
17222       ELSE
17223          DO 23 K=1,5
17224             PCAS(2,K) = ZERO
17225             IF (K.LE.3) COSCAS(2,K) = ZERO
17226    23    CONTINUE
17227          PTOCAS(2) = ZERO
17228          BGCAS(2)  = ZERO
17229          GACAS(2)  = ZERO
17230          BECAS(2)  = ZERO
17231       ENDIF
17232
17233 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
17234 * potential (see CONUCL)
17235       RNUC(1)  = (RPROJ+4.605D0*PDIF)*FM2MM
17236       RNUC(2)  = (RTARG+4.605D0*PDIF)*FM2MM
17237 * impact parameter (the projectile moving along z)
17238       BIMPC(1) = ZERO
17239       BIMPC(2) = BIMPAC*FM2MM
17240
17241 * get position of initial hadron in projectile/target rest-syst.
17242       DO 3 K=1,4
17243          VTXCAS(1,K) = WHKK(K,IDXCAS)
17244          VTXCAS(2,K) = VHKK(K,IDXCAS)
17245     3 CONTINUE
17246
17247       ICAS = 1
17248       I2   = 2
17249       IF (NCAS.EQ.-1) THEN
17250          ICAS = 2
17251          I2   = 1
17252       ENDIF
17253
17254       IF (PTOCAS(ICAS).LT.TINY10) THEN
17255          WRITE(LOUT,1000) PTOCAS
17256  1000    FORMAT(1X,'INUCAS:   warning! zero momentum of initial',
17257      &          '  hadron ',/,20X,2E12.4)
17258          GOTO 9999
17259       ENDIF
17260
17261 * reset spectator flags
17262       NSPE = 0
17263       IDXSPE(1) = 0
17264       IDXSPE(2) = 0
17265       IDSPE(1)  = 0
17266       IDSPE(2)  = 0
17267
17268 * formation length (in fm)
17269 C     IF (LCAS) THEN
17270 C        DEL0 = ZERO
17271 C     ELSE
17272          DEL0 = TAUFOR*BGCAS(ICAS)
17273          IF (ITAUVE.EQ.1) THEN
17274             AMT  = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
17275             DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
17276          ENDIF
17277 C     ENDIF
17278 *   sample from exp(-del/del0)
17279       DEL1   = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
17280 * save formation time
17281       TAUSA1 = DEL1/BGCAS(ICAS)
17282       REL1   = TAUSA1*BGCAS(I2)
17283
17284       DEL    = DEL1
17285       TAUSAM = DEL/BGCAS(ICAS)
17286       REL    = TAUSAM*BGCAS(I2)
17287
17288 * special treatment for negative particles unable to escape
17289 * nuclear potential (implemented for ap, pi-, K- only)
17290       LABSOR = .FALSE.
17291       IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
17292 *   threshold energy = nuclear potential + Coulomb potential
17293 *   (nuclear potential for hadron-nucleus interactions only)
17294          ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
17295          IF (PCAS(ICAS,4).LT.ETHR) THEN
17296             DO 4 K=1,5
17297                PCAS1(K) = PCAS(ICAS,K)
17298     4       CONTINUE
17299 *   "absorb" negative particle in nucleus
17300             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
17301             IF (IREJ1.NE.0) GOTO 9999
17302             IF (NSPE.GE.1) LABSOR = .TRUE.
17303          ENDIF
17304       ENDIF
17305
17306 * if the initial particle has not been absorbed proceed with
17307 * "normal" cascade
17308       IF (.NOT.LABSOR) THEN
17309
17310 *   calculate coordinates of hadron at the end of the formation zone
17311 *   transport-time and -step in the rest system where this step is
17312 *   treated
17313          DSTEP  = DEL*FM2MM
17314          DTIME  = DSTEP/BECAS(ICAS)
17315          RSTEP  = REL*FM2MM
17316          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17317             RTIME = RSTEP/BECAS(I2)
17318          ELSE
17319             RTIME = ZERO
17320          ENDIF
17321 *   save step whithout considering the overlapping region
17322          DSTEP1 = DEL1*FM2MM
17323          DTIME1 = DSTEP1/BECAS(ICAS)
17324          RSTEP1 = REL1*FM2MM
17325          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17326             RTIME1 = RSTEP1/BECAS(I2)
17327          ELSE
17328             RTIME1 = ZERO
17329          ENDIF
17330 *   transport to the end of the formation zone in this system
17331          DO 5 K=1,3
17332             VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
17333             VTXCA1(I2,K)   = VTXCAS(I2,K)  +RSTEP1*COSCAS(I2,K)
17334             VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
17335             VTXCAS(I2,K)   = VTXCAS(I2,K)  +RSTEP*COSCAS(I2,K)
17336     5    CONTINUE
17337          VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
17338          VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME1
17339          VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17340          VTXCAS(I2,4)   = VTXCAS(I2,4)  +RTIME
17341
17342          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17343             XCAS   = VTXCAS(ICAS,1)
17344             YCAS   = VTXCAS(ICAS,2)
17345             XNCLTA = BIMPAC*FM2MM
17346             RNCLPR = (RPROJ+RNUCLE)*FM2MM
17347             RNCLTA = (RTARG+RNUCLE)*FM2MM
17348 C           RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
17349 C           RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
17350 C           RNCLPR = (RPROJ)*FM2MM
17351 C           RNCLTA = (RTARG)*FM2MM
17352             RCASPR = SQRT( XCAS**2        +YCAS**2)
17353             RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
17354             IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
17355                IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
17356             ENDIF
17357          ENDIF
17358
17359 *   check if particle is already outside of the corresp. nucleus
17360          RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
17361      &                VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
17362          IF (RDIST.GE.RNUC(ICAS)) THEN
17363 *   here: IDCH is the generation of the final state part. starting
17364 *   with zero for hadronization products
17365 *   flag particles of generation 0 being outside the nuclei after
17366 *   formation time (to be used for excitation energy calculation)
17367             IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
17368      &         NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
17369             GOTO 9997
17370          ENDIF
17371          DIST   = DLARGE
17372          DISTP  = DLARGE
17373          DISTN  = DLARGE
17374          IDXP   = 0
17375          IDXN   = 0
17376
17377 *   already here: skip particles being outside HADRIN "energy-window"
17378 *   to avoid wasting of time
17379          NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
17380          IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
17381             NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
17382 C           WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
17383 C1002       FORMAT(1X,'INUCAS:   warning! momentum of particle with ',
17384 C    &             'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
17385 C    &             E12.4,', above or below HADRIN-thresholds',I6)
17386             NSPE = 0
17387             GOTO 9997
17388          ENDIF
17389
17390          DO 7 IDXHKK=1,NOINC
17391             I = IDXINC(IDXHKK)
17392 *   scan DTEVT1 for unwounded or excited nucleons
17393             IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
17394                DO 8 K=1,3
17395                   IF (ICAS.EQ.1) THEN
17396                      VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
17397                   ELSEIF (ICAS.EQ.2) THEN
17398                      VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
17399                   ENDIF
17400     8          CONTINUE
17401                POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
17402      &                  VTXDST(2)*COSCAS(ICAS,2)+
17403      &                  VTXDST(3)*COSCAS(ICAS,3)
17404 *   check if nucleon is situated in forward direction
17405                IF (POSNUC.GT.ZERO) THEN
17406 *   distance between hadron and this nucleon
17407                   DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17408      &                          VTXDST(3)**2)
17409 *   impact parameter
17410                   BIMNU2 = DISTNU**2-POSNUC**2
17411                   IF (BIMNU2.LT.ZERO) THEN
17412                      WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
17413  1001                FORMAT(1X,'INUCAS:   warning! inconsistent impact',
17414      &                      '  parameter ',/,20X,3E12.4)
17415                      GOTO 7
17416                   ENDIF
17417                   BIMNU  = SQRT(BIMNU2)
17418 *   maximum impact parameter to have interaction
17419                   IDNUC  = IDT_ICIHAD(IDHKK(I))
17420                   IDNUC1 = IDT_MCHAD(IDNUC)
17421                   IDCAS1 = IDT_MCHAD(IDCAS)
17422                   DO 19 K=1,5
17423                      PCAS1(K) = PCAS(ICAS,K)
17424                      PNUC(K)  = PHKK(K,I)
17425    19             CONTINUE
17426 * Lorentz-parameter for trafo into rest-system of target
17427                   DO 18 K=1,4
17428                      BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
17429    18             CONTINUE
17430 * transformation of projectile into rest-system of target
17431                   CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
17432      &                        PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
17433      &                        PPTOT,PX,PY,PZ,PE)
17434 **
17435 C                 CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
17436 C                 CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
17437                   DUMZER = ZERO
17438                   CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
17439                   CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
17440                   IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
17441      &                (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
17442                   SIGIN = SIGTOT-SIGEL-SIGAB
17443 C                 SIGTOT = SIGIN+SIGEL+SIGAB
17444 **
17445                   BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
17446 *   check if interaction is possible
17447                   IF (BIMNU.LE.BIMMAX) THEN
17448 *   get nucleon with smallest distance and kind of interaction
17449 *   (elastic/inelastic)
17450                      IF (DISTNU.LT.DIST) THEN
17451                         DIST      = DISTNU
17452                         BINT      = BIMNU
17453                         IF (IDNUC.NE.IDSPE(1)) THEN
17454                            IDSPE(2)  = IDSPE(1)
17455                            IDXSPE(2) = IDXSPE(1)
17456                            IDSPE(1)  = IDNUC
17457                         ENDIF
17458                         IDXSPE(1) = I
17459                         NSPE      = 1
17460 **sr
17461                         SELA = SIGEL
17462                         SABS = SIGAB
17463                         STOT = SIGTOT
17464 C                       IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
17465 C                          SELA = SIGEL
17466 C                          STOT = SIGIN+SIGEL
17467 C                       ELSE
17468 C                          SELA = SIGEL+0.75D0*SIGIN
17469 C                          STOT = 0.25D0*SIGIN+SELA
17470 C                       ENDIF
17471 **
17472                      ENDIF
17473                   ENDIf
17474                ENDIF
17475                DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17476      &                       VTXDST(3)**2)
17477                IDNUC  = IDT_ICIHAD(IDHKK(I))
17478                IF (IDNUC.EQ.1) THEN
17479                   IF (DISTNU.LT.DISTP) THEN
17480                      DISTP = DISTNU
17481                      IDXP  = I
17482                      POSP  = POSNUC
17483                   ENDIF
17484                ELSEIF (IDNUC.EQ.8) THEN
17485                   IF (DISTNU.LT.DISTN) THEN
17486                      DISTN = DISTNU
17487                      IDXN  = I
17488                      POSN  = POSNUC
17489                   ENDIF
17490                ENDIF
17491             ENDIF
17492     7    CONTINUE
17493
17494 * there is no nucleon for a secondary interaction
17495          IF (NSPE.EQ.0) GOTO 9997
17496
17497 C        IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
17498 C    &      WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
17499          IF (IDXSPE(2).EQ.0) THEN
17500             IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
17501 C              DO 80 K=1,3
17502 C                 IF (ICAS.EQ.1) THEN
17503 C                    VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
17504 C                 ELSEIF (ICAS.EQ.2) THEN
17505 C                    VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
17506 C                 ENDIF
17507 C  80          CONTINUE
17508 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17509 C    &                       VTXDST(3)**2)
17510 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
17511                   IDXSPE(2) = IDXN
17512                   IDSPE(2)  = 8
17513 C              ELSE
17514 C                 STOT = STOT-SABS
17515 C                 SABS = ZERO
17516 C              ENDIF
17517             ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
17518 C              DO 81 K=1,3
17519 C                 IF (ICAS.EQ.1) THEN
17520 C                    VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
17521 C                 ELSEIF (ICAS.EQ.2) THEN
17522 C                    VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
17523 C                 ENDIF
17524 C  81          CONTINUE
17525 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17526 C    &                       VTXDST(3)**2)
17527 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
17528                   IDXSPE(2) = IDXP
17529                   IDSPE(2)  = 1
17530 C              ELSE
17531 C                 STOT = STOT-SABS
17532 C                 SABS = ZERO
17533 C              ENDIF
17534             ELSE
17535                STOT = STOT-SABS
17536                SABS = ZERO
17537             ENDIF
17538          ENDIF
17539          RR = DT_RNDM(DIST)
17540          IF (RR.LT.SELA/STOT) THEN
17541             IPROC = 2
17542          ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
17543             IPROC = 3
17544          ELSE
17545             IPROC = 1
17546          ENDIF
17547
17548          DO 9 K=1,5
17549             PCAS1(K) = PCAS(ICAS,K)
17550             PNUC(K)  = PHKK(K,IDXSPE(1))
17551     9    CONTINUE
17552          IF (IPROC.EQ.3) THEN
17553 * 2-nucleon absorption of pion
17554             NSPE = 2
17555             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
17556             IF (IREJ1.NE.0) GOTO 9999
17557             IF (NSPE.GE.1) LABSOR = .TRUE.
17558          ELSE
17559 * sample secondary interaction
17560             IDNUC = IDBAM(IDXSPE(1))
17561             CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
17562             IF (IREJ1.EQ.1) GOTO 9999
17563             IF (IREJ1.GT.1) GOTO 9998
17564          ENDIF
17565       ENDIF
17566
17567 * update arrays to include Pauli-principle
17568       DO 10 I=1,NSPE
17569          IF (NWOUND(ICAS).LE.299) THEN
17570             NWOUND(ICAS) = NWOUND(ICAS)+1
17571             EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
17572          ENDIF
17573    10 CONTINUE
17574
17575 * dump initial hadron for energy-momentum conservation check
17576       IF (LEMCCK)
17577      &   CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
17578      &               PCAS(ICAS,4),1,IDUM,IDUM)
17579
17580 * dump final state particles into DTEVT1
17581
17582 *   check if Pauli-principle is fulfilled
17583       NPAULI = 0
17584       NWTMP(1) = NWOUND(1)
17585       NWTMP(2) = NWOUND(2)
17586       DO 111 I=1,NFSP
17587          NPAULI = 0
17588          J1 = 2
17589          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17590      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
17591          DO 117 J=1,J1
17592             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
17593             IF (J.EQ.1) THEN
17594                IDX = ICAS
17595                PE  = PFSP(4,I)
17596             ELSE
17597                IDX  = I2
17598                MODE = 1
17599                IF (IDX.EQ.1) MODE = -1
17600                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
17601             ENDIF
17602 * first check if cascade step is forbidden due to Pauli-principle
17603 * (in case of absorpion this step is forced)
17604             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17605      &          (IDFSP(I).EQ.8))) THEN
17606 *   get nuclear potential barrier
17607                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17608                IF (IDFSP(I).EQ.1) THEN
17609                   POTLOW = POT-EBINDP(IDX)
17610                ELSE
17611                   POTLOW = POT-EBINDN(IDX)
17612                ENDIF
17613 *   final state particle not able to escape nucleus
17614                IF (PE.LE.POTLOW) THEN
17615 *     check if there are wounded nucleons
17616                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17617      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
17618                      NPAULI      = NPAULI+1
17619                      NWOUND(IDX) = NWOUND(IDX)-1
17620                   ELSE
17621 *     interaction prohibited by Pauli-principle
17622                      NWOUND(1) = NWTMP(1)
17623                      NWOUND(2) = NWTMP(2)
17624                      GOTO 9997
17625                   ENDIF
17626                ENDIF
17627             ENDIF
17628   117    CONTINUE
17629   111 CONTINUE
17630
17631       NPAULI = 0
17632       NWOUND(1) = NWTMP(1)
17633       NWOUND(2) = NWTMP(2)
17634
17635       DO 11 I=1,NFSP
17636
17637          IST = ISTHKK(IDXCAS)
17638
17639          NPAULI = 0
17640          J1 = 2
17641          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17642      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
17643          DO 17 J=1,J1
17644             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
17645             IDX = ICAS
17646             PE  = PFSP(4,I)
17647             IF (J.EQ.2) THEN
17648                IDX = I2
17649                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
17650             ENDIF
17651 * first check if cascade step is forbidden due to Pauli-principle
17652 * (in case of absorpion this step is forced)
17653             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17654      &          (IDFSP(I).EQ.8))) THEN
17655 *   get nuclear potential barrier
17656                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17657                IF (IDFSP(I).EQ.1) THEN
17658                   POTLOW = POT-EBINDP(IDX)
17659                ELSE
17660                   POTLOW = POT-EBINDN(IDX)
17661                ENDIF
17662 *   final state particle not able to escape nucleus
17663                IF (PE.LE.POTLOW) THEN
17664 *     check if there are wounded nucleons
17665                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17666      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
17667                      NWOUND(IDX) = NWOUND(IDX)-1
17668                      NPAULI = NPAULI+1
17669                      IST    = 14+IDX
17670                   ELSE
17671 *     interaction prohibited by Pauli-principle
17672                      NWOUND(1) = NWTMP(1)
17673                      NWOUND(2) = NWTMP(2)
17674                      GOTO 9997
17675                   ENDIF
17676 **sr
17677 c               ELSEIF (PE.LE.POT) THEN
17678 cC              ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
17679 cC                 NWOUND(IDX) = NWOUND(IDX)-1
17680 c**
17681 c                  NPAULI = NPAULI+1
17682 c                  IST    = 14+IDX
17683                ENDIF
17684             ENDIF
17685    17    CONTINUE
17686
17687 * dump final state particles for energy-momentum conservation check
17688          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
17689      &                           -PFSP(4,I),2,IDUM,IDUM)
17690
17691          PX = PFSP(1,I)
17692          PY = PFSP(2,I)
17693          PZ = PFSP(3,I)
17694          PE = PFSP(4,I)
17695          IF (ABS(IST).EQ.1) THEN
17696 * transform particles back into n-n cms
17697 * LEPTO: leave final state particles in target rest frame
17698 C           IF (MCGENE.EQ.3) THEN
17699 C              PFSP(1,I) = PX
17700 C              PFSP(2,I) = PY
17701 C              PFSP(3,I) = PZ
17702 C              PFSP(4,I) = PE
17703 C           ELSE
17704                IMODE = ICAS+1
17705                CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17706      &                     PFSP(4,I),IDFSP(I),IMODE)
17707 C           ENDIF
17708          ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
17709 * target cascade but fsp got stuck in proj. --> transform it into
17710 * proj. rest system
17711             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17712      &                  PFSP(4,I),IDFSP(I),-1)
17713          ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
17714 * proj. cascade but fsp got stuck in target --> transform it into
17715 * target 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          ENDIF
17719
17720 * dump final state particles into DTEVT1
17721          IGEN = IDCH(IDXCAS)+1
17722          ID   = IDT_IPDGHA(IDFSP(I))
17723          IXR  = 0
17724          IF (LABSOR) IXR = 99
17725          CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
17726      &               PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
17727
17728 * update the counter for particles which got stuck inside the nucleus
17729          IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
17730             NOINC = NOINC+1
17731             IDXINC(NOINC) = NHKK
17732          ENDIF
17733          IF (LABSOR) THEN
17734 *   in case of absorption the spatial treatment is an approximate
17735 *   solution anyway (the positions of the nucleons which "absorb" the
17736 *   cascade particle are not taken into consideration) therefore the
17737 *   particles are produced at the position of the cascade particle
17738             DO 12 K=1,4
17739                WHKK(K,NHKK) = WHKK(K,IDXCAS)
17740                VHKK(K,NHKK) = VHKK(K,IDXCAS)
17741    12       CONTINUE
17742          ELSE
17743 *   DDISTL - distance the cascade particle moves to the intera. point
17744 *   (the position where impact-parameter = distance to the interacting
17745 *   nucleon), DIST - distance to the interacting nucleon at the time of
17746 *   formation of the cascade particle, BINT - impact-parameter of this
17747 *   cascade-interaction
17748             DDISTL = SQRT(DIST**2-BINT**2)
17749             DTIME  = DDISTL/BECAS(ICAS)
17750             DTIMEL = DDISTL/BGCAS(ICAS)
17751             RDISTL = DTIMEL*BGCAS(I2)
17752             IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17753                RTIME = RDISTL/BECAS(I2)
17754             ELSE
17755                RTIME = ZERO
17756             ENDIF
17757 *   RDISTL, RTIME are this step and time in the rest system of the other
17758 *   nucleus
17759             DO 13 K=1,3
17760                VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
17761                VTXCA1(I2,K)   = VTXCAS(I2,K)  +COSCAS(I2,K)  *RDISTL
17762    13       CONTINUE
17763             VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17764             VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME
17765 *   position of particle production is half the impact-parameter to
17766 *   the interacting nucleon
17767             DO 14 K=1,3
17768                WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
17769                VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
17770    14       CONTINUE
17771 *   time of production of secondary = time of interaction
17772             WHKK(4,NHKK) = VTXCA1(1,4)
17773             VHKK(4,NHKK) = VTXCA1(2,4)
17774          ENDIF
17775
17776    11 CONTINUE
17777
17778 * modify status and position of cascade particle (the latter for
17779 * statistics reasons only)
17780       ISTHKK(IDXCAS) = 2
17781       IF (LABSOR) ISTHKK(IDXCAS) = 19
17782       IF (.NOT.LABSOR) THEN
17783          DO 15 K=1,4
17784             WHKK(K,IDXCAS) = VTXCA1(1,K)
17785             VHKK(K,IDXCAS) = VTXCA1(2,K)
17786    15    CONTINUE
17787       ENDIF
17788
17789       DO 16 I=1,NSPE
17790          IS = IDXSPE(I)
17791 * dump interacting nucleons for energy-momentum conservation check
17792          IF (LEMCCK)
17793      &      CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
17794      &                                                  2,IDUM,IDUM)
17795 * modify entry for interacting nucleons
17796          IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
17797          IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
17798          IF (I.GE.2) THEN
17799             JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
17800             JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
17801          ENDIF
17802    16 CONTINUE
17803
17804 * check energy-momentum conservation
17805       IF (LEMCCK) THEN
17806          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
17807          IF (IREJ1.NE.0) GOTO 9999
17808       ENDIF
17809
17810 * update counter
17811       IF (LABSOR) THEN
17812          NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
17813       ELSE
17814          IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
17815          IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
17816       ENDIF
17817
17818       RETURN
17819
17820  9997 CONTINUE
17821  9998 CONTINUE
17822 * transport-step but no cascade step due to configuration (i.e. there
17823 * is no nucleon for interaction etc.)
17824       IF (LCAS) THEN
17825          DO 100 K=1,4
17826 C           WHKK(K,IDXCAS) = VTXCAS(1,K)
17827 C           VHKK(K,IDXCAS) = VTXCAS(2,K)
17828             WHKK(K,IDXCAS) = VTXCA1(1,K)
17829             VHKK(K,IDXCAS) = VTXCA1(2,K)
17830   100    CONTINUE
17831       ENDIF
17832
17833 C9998 CONTINUE
17834 * no cascade-step because of configuration
17835 * (i.e. hadron outside nucleus etc.)
17836       LCAS = .TRUE.
17837       RETURN
17838
17839  9999 CONTINUE
17840 * rejection
17841       IREJ = 1
17842       RETURN
17843       END
17844
17845 *$ CREATE DT_ABSORP.FOR
17846 *COPY DT_ABSORP
17847 *
17848 *===absorp=============================================================*
17849 *
17850       SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
17851
17852 ************************************************************************
17853 * Two-nucleon absorption of antiprotons, pi-, and K-.                  *
17854 * Antiproton absorption is handled by HADRIN.                          *
17855 * The following channels for meson-absorption are considered:          *
17856 *          pi- + p + p ---> n + p                                      *
17857 *          pi- + p + n ---> n + n                                      *
17858 *          K-  + p + p ---> sigma+ + n / Lam + p / sigma0 + p          *
17859 *          K-  + p + n ---> sigma- + n / Lam + n / sigma0 + n          *
17860 *          K-  + p + p ---> sigma- + n                                 *
17861 *      IDCAS, PCAS   identity, momentum of particle to be absorbed     *
17862 *      NCAS =  1     intranuclear cascade in projectile                *
17863 *           = -1     intranuclear cascade in target                    *
17864 *      NSPE          number of spectator nucleons involved             *
17865 *      IDXSPE(2)     DTEVT1-indices of spectator nucleons involved     *
17866 * Revised version of the original STOPIK written by HJM and J. Ranft.  *
17867 * This version dated 24.02.95 is written by S. Roesler                 *
17868 ************************************************************************
17869
17870       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17871       SAVE
17872
17873       PARAMETER ( LINP = 10 ,
17874      &            LOUT = 6 ,
17875      &            LDAT = 9 )
17876
17877       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17878      &           ONETHI=0.3333D0,TWOTHI=0.6666D0)
17879
17880 * event history
17881
17882       PARAMETER (NMXHKK=200000)
17883
17884       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17885      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17886      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17887
17888 * extended event history
17889       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17890      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17891      &                IHIST(2,NMXHKK)
17892
17893 * flags for input different options
17894       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17895       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17896      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17897
17898 * final state after inc step
17899       PARAMETER (MAXFSP=10)
17900       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17901
17902 * particle properties (BAMJET index convention)
17903       CHARACTER*8  ANAME
17904       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17905      &                IICH(210),IIBAR(210),K1(210),K2(210)
17906
17907       DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17908      &          PTOT3P(4),BG3P(4),
17909      &          ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17910
17911       IREJ = 0
17912       NFSP = 0
17913
17914 * skip particles others than ap, pi-, K- for mode=0
17915       IF ((MODE.EQ.0).AND.
17916      &    (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17917 * skip particles others than pions for mode=1
17918 * (2-nucleon absorption in intranuclear cascade)
17919       IF ((MODE.EQ.1).AND.
17920      &    (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17921
17922       NUCAS = NCAS
17923       IF (NUCAS.EQ.-1) NUCAS = 2
17924
17925       IF (MODE.EQ.0) THEN
17926 * scan spectator nucleons for nucleons being able to "absorb"
17927          NSPE      = 0
17928          IDXSPE(1) = 0
17929          IDXSPE(2) = 0
17930          DO 1 I=1,NHKK
17931             IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17932                NSPE         = NSPE+1
17933                IDXSPE(NSPE) = I
17934                IDSPE(NSPE)  = IDBAM(I)
17935                IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17936                IF (NSPE.EQ.2) THEN
17937                   IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17938      &                                  (IDSPE(2).EQ.8)) THEN
17939 *    there is no pi-+n+n channel
17940                      NSPE = 1
17941                      GOTO 1
17942                   ELSE
17943                      GOTO 2
17944                   ENDIF
17945                ENDIF
17946             ENDIF
17947     1    CONTINUE
17948
17949     2    CONTINUE
17950       ENDIF
17951 * transform excited projectile nucleons (status=15) into proj. rest s.
17952       DO 3 I=1,NSPE
17953          DO 4 K=1,5
17954             PSPE(I,K) = PHKK(K,IDXSPE(I))
17955     4    CONTINUE
17956     3 CONTINUE
17957
17958 * antiproton absorption
17959       IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17960          DO 5 K=1,5
17961             PSPE1(K) = PSPE(1,K)
17962     5    CONTINUE
17963          CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17964          IF (IREJ1.NE.0) GOTO 9999
17965
17966 * meson absorption
17967       ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17968      &                      .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17969          IF (IDCAS.EQ.14) THEN
17970 *   pi- absorption
17971             IDFSP(1) = 8
17972             IDFSP(2) = 8
17973             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17974          ELSEIF (IDCAS.EQ.13) THEN
17975 *   pi+ absorption
17976             IDFSP(1) = 1
17977             IDFSP(2) = 1
17978             IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17979          ELSEIF (IDCAS.EQ.23) THEN
17980 *   pi0 absorption
17981             IDFSP(1) = IDSPE(1)
17982             IDFSP(2) = IDSPE(2)
17983          ELSEIF (IDCAS.EQ.16) THEN
17984 *   K- absorption
17985             R = DT_RNDM(PCAS)
17986             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17987                IF (R.LT.ONETHI) THEN
17988                   IDFSP(1) = 21
17989                   IDFSP(2) = 8
17990                ELSEIF (R.LT.TWOTHI) THEN
17991                   IDFSP(1) = 17
17992                   IDFSP(2) = 1
17993                ELSE
17994                   IDFSP(1) = 22
17995                   IDFSP(2) = 1
17996                ENDIF
17997             ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17998                IDFSP(1) = 20
17999                IDFSP(2) = 8
18000             ELSE
18001                IF (R.LT.ONETHI) THEN
18002                   IDFSP(1) = 20
18003                   IDFSP(2) = 1
18004                ELSEIF (R.LT.TWOTHI) THEN
18005                   IDFSP(1) = 17
18006                   IDFSP(2) = 8
18007                ELSE
18008                   IDFSP(1) = 22
18009                   IDFSP(2) = 8
18010                ENDIF
18011             ENDIF
18012          ENDIF
18013 *   dump initial particles for energy-momentum cons. check
18014          IF (LEMCCK) THEN
18015             CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
18016             CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
18017      &                                                    IDUM,IDUM)
18018             CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
18019      &                                                    IDUM,IDUM)
18020          ENDIF
18021 *   get Lorentz-parameter of 3 particle initial state
18022          DO 6 K=1,4
18023             PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
18024     6    CONTINUE
18025          P3P  = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
18026          AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
18027          DO 7 K=1,4
18028             BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
18029     7    CONTINUE
18030 *   2-particle decay of the 3-particle compound system
18031          CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
18032      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
18033      &               AAM(IDFSP(1)),AAM(IDFSP(2)))
18034          DO 8 I=1,2
18035             SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
18036             PX  = PCMF(I)*COFF(I)*SDF
18037             PY  = PCMF(I)*SIFF(I)*SDF
18038             PZ  = PCMF(I)*CODF(I)
18039             CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
18040      &                  ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
18041      &                  PFSP(4,I))
18042             PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
18043 *   check consistency of kinematics
18044             IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
18045                WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
18046  1001          FORMAT(1X,'ABSORP:   warning! inconsistent',
18047      &                ' tree-particle kinematics',/,20X,'id: ',I3,
18048      &                ' AAM = ',E10.4,' MFSP = ',E10.4)
18049             ENDIF
18050 *   dump final state particles for energy-momentum cons. check
18051             IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18052      &                              -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18053     8    CONTINUE
18054          NFSP = 2
18055          IF (LEMCCK) THEN
18056             CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
18057             IF (IREJ1.NE.0) THEN
18058                WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
18059      &                      AM3P
18060                GOTO 9999
18061             ENDIF
18062          ENDIF
18063       ELSE
18064          IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
18065  1000    FORMAT(1X,'ABSORP:   warning! absorption for particle ',I3,
18066      &          ' impossible',/,20X,'too few spectators (',I2,')')
18067          NSPE = 0
18068       ENDIF
18069
18070       RETURN
18071
18072  9999 CONTINUE
18073       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
18074       IREJ = 1
18075       RETURN
18076       END
18077
18078 *$ CREATE DT_HADRIN.FOR
18079 *COPY DT_HADRIN
18080 *
18081 *===hadrin=============================================================*
18082 *
18083       SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
18084
18085 ************************************************************************
18086 * Interface to the HADRIN-routines for inelastic and elastic           *
18087 * scattering.                                                          *
18088 *      IDPR,PPR(5)   identity, momentum of projectile                  *
18089 *      IDTA,PTA(5)   identity, momentum of target                      *
18090 *      MODE  = 1     inelastic interaction                             *
18091 *            = 2     elastic   interaction                             *
18092 * Revised version of the original FHAD.                                *
18093 * This version dated 27.10.95 is written by S. Roesler                 *
18094 ************************************************************************
18095
18096       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18097       SAVE
18098
18099       PARAMETER ( LINP = 10 ,
18100      &            LOUT = 6 ,
18101      &            LDAT = 9 )
18102
18103       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
18104      &           TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
18105
18106       LOGICAL LCORR,LMSSG
18107
18108 * flags for input different options
18109       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18110       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18111      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18112
18113 * final state after inc step
18114       PARAMETER (MAXFSP=10)
18115       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18116
18117 * particle properties (BAMJET index convention)
18118       CHARACTER*8  ANAME
18119       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18120      &                IICH(210),IIBAR(210),K1(210),K2(210)
18121 * output-common for DHADRI/ELHAIN
18122
18123 * final state from HADRIN interaction
18124       PARAMETER (MAXFIN=10)
18125       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
18126      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
18127
18128       DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
18129      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
18130
18131       DATA LMSSG /.TRUE./
18132
18133       IREJ  = 0
18134       NFSP  = 0
18135       KCORR = 0
18136       IMCORR(1) = 0
18137       IMCORR(2) = 0
18138       LCORR = .FALSE.
18139
18140 *   dump initial particles for energy-momentum cons. check
18141       IF (LEMCCK) THEN
18142          CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
18143          CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
18144       ENDIF
18145
18146       AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
18147       AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
18148       IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
18149      &    (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
18150      &    (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
18151          IF (LMSSG.AND.(IOULEV(3).GT.0))
18152      &   WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
18153  1000    FORMAT(1X,'HADRIN:   warning! inconsistent projectile/target',
18154      &          ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
18155      &          E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
18156          LMSSG = .FALSE.
18157          LCORR = .TRUE.
18158       ENDIF
18159
18160 * convert initial state particles into particles which can be
18161 * handled by HADRIN
18162       IDHPR = IDPR
18163       IDHTA = IDTA
18164       IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
18165          IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
18166          DO 1 K=1,4
18167             P1IN(K) = PPR(K)
18168             P2IN(K) = PTA(K)
18169     1    CONTINUE
18170          XM1 = AAM(IDHPR)
18171          XM2 = AAM(IDHTA)
18172          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18173          IF (IREJ1.GT.0) THEN
18174             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
18175             GOTO 9999
18176          ENDIF
18177          DO 2 K=1,4
18178             PPR(K) = P1OUT(K)
18179             PTA(K) = P2OUT(K)
18180     2    CONTINUE
18181          PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
18182          PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
18183       ENDIF
18184
18185 * Lorentz-parameter for trafo into rest-system of target
18186       DO 3 K=1,4
18187          BGTA(K) = PTA(K)/PTA(5)
18188     3 CONTINUE
18189 * transformation of projectile into rest-system of target
18190       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
18191      &            PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
18192      &            PPR1(4))
18193
18194 * direction cosines of projectile in target rest system
18195       CX = PPR1(1)/PPRTO1
18196       CY = PPR1(2)/PPRTO1
18197       CZ = PPR1(3)/PPRTO1
18198
18199 * sample inelastic interaction
18200       IF (MODE.EQ.1) THEN
18201          CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
18202          IF (IRH.EQ.1) GOTO 9998
18203 * sample elastic interaction
18204       ELSEIF (MODE.EQ.2) THEN
18205          CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
18206          IF (IREJ1.NE.0) THEN
18207             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
18208             GOTO 9999
18209          ENDIF
18210          IF (IRH.EQ.1) GOTO 9998
18211       ELSE
18212          WRITE(LOUT,1001) MODE,INTHAD
18213  1001    FORMAT(1X,'HADRIN:   warning! inconsistent interaction mode',
18214      &          I4,' (INTHAD =',I4,')')
18215          GOTO 9999
18216       ENDIF
18217
18218 * transform final state particles back into Lab.
18219       DO 4 I=1,IRH
18220          NFSP = NFSP+1
18221          PX   = CXRH(I)*PLRH(I)
18222          PY   = CYRH(I)*PLRH(I)
18223          PZ   = CZRH(I)*PLRH(I)
18224          CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
18225      &               PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
18226      &               PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
18227          IDFSP(NFSP) = ITRH(I)
18228          AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
18229      &                                            PFSP(3,NFSP)**2
18230          IF (AMFSP2.LT.-TINY3) THEN
18231             WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
18232      &                       PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
18233  1002       FORMAT(1X,'HADRIN:   warning! final state particle (id = ',
18234      &             I2,') with negative mass^2',/,1X,5E12.4)
18235             GOTO 9999
18236          ELSE
18237             PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
18238             IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
18239                WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
18240      &                          PFSP(5,NFSP)
18241  1003          FORMAT(1X,'HADRIN:   warning! final state particle',
18242      &                ' (id = ',I2,') with inconsistent mass',/,1X,
18243      &                2E12.4)
18244                KCORR         = KCORR+1
18245                IF (KCORR.GT.2) GOTO 9999
18246                IMCORR(KCORR) = NFSP
18247             ENDIF
18248          ENDIF
18249 *   dump final state particles for energy-momentum cons. check
18250          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18251      &                           -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18252     4 CONTINUE
18253
18254 * transform momenta on mass shell in case of inconsistencies in
18255 * HADRIN
18256       IF (KCORR.GT.0) THEN
18257          IF (KCORR.EQ.2) THEN
18258             I1 = IMCORR(1)
18259             I2 = IMCORR(2)
18260          ELSE
18261             IF (IMCORR(1).EQ.1) THEN
18262                I1 = 1
18263                I2 = 2
18264             ELSE
18265                I1 = 1
18266                I2 = IMCORR(1)
18267             ENDIF
18268          ENDIF
18269          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
18270      &                           PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
18271          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
18272      &                           PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
18273          DO 5 K=1,4
18274             P1IN(K) = PFSP(K,I1)
18275             P2IN(K) = PFSP(K,I2)
18276     5    CONTINUE
18277          XM1 = AAM(IDFSP(I1))
18278          XM2 = AAM(IDFSP(I2))
18279          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18280          IF (IREJ1.GT.0) THEN
18281             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
18282 C           GOTO 9999
18283          ENDIF
18284          DO 6 K=1,4
18285             PFSP(K,I1) = P1OUT(K)
18286             PFSP(K,I2) = P2OUT(K)
18287     6    CONTINUE
18288          PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
18289      &                    -PFSP(2,I1)**2-PFSP(3,I1)**2)
18290          PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
18291      &                    -PFSP(2,I2)**2-PFSP(3,I2)**2)
18292 *   dump final state particles for energy-momentum cons. check
18293          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
18294      &                           -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
18295          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
18296      &                           -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
18297       ENDIF
18298
18299 * check energy-momentum conservation
18300       IF (LEMCCK) THEN
18301          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
18302          IF (IREJ1.NE.0) GOTO 9999
18303       ENDIF
18304
18305       RETURN
18306
18307  9998 CONTINUE
18308       IREJ = 2
18309       RETURN
18310
18311  9999 CONTINUE
18312       IREJ = 1
18313       RETURN
18314       END
18315
18316 *$ CREATE DT_HADCOL.FOR
18317 *COPY DT_HADCOL
18318 *
18319 *===hadcol=============================================================*
18320 *
18321       SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
18322
18323 ************************************************************************
18324 * Interface to the HADRIN-routines for inelastic and elastic           *
18325 * scattering. This subroutine samples hadron-nucleus interactions      *
18326 * below DPM-threshold.                                                 *
18327 *      IDPROJ        BAMJET-index of projectile hadron                 *
18328 *      PPN           projectile momentum in target rest frame          *
18329 *      IDXTAR        DTEVT1-index of target nucleon undergoing         *
18330 *                    interaction with projectile hadron                *
18331 * This subroutine replaces HADHAD.                                     *
18332 * This version dated 5.5.95 is written by S. Roesler                   *
18333 ************************************************************************
18334
18335       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18336       SAVE
18337
18338       PARAMETER ( LINP = 10 ,
18339      &            LOUT = 6 ,
18340      &            LDAT = 9 )
18341
18342       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
18343
18344       LOGICAL LSTART
18345
18346 * event history
18347
18348       PARAMETER (NMXHKK=200000)
18349
18350       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18351      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18352      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18353
18354 * extended event history
18355       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18356      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18357      &                IHIST(2,NMXHKK)
18358
18359 * nuclear potential
18360       LOGICAL LFERMI
18361       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18362      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18363      &                ETACOU(2),ICOUL,LFERMI
18364
18365 * interface HADRIN-DPM
18366       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
18367
18368 * parameter for intranuclear cascade
18369       LOGICAL LPAULI
18370       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
18371
18372 * final state after inc step
18373       PARAMETER (MAXFSP=10)
18374       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18375
18376 * particle properties (BAMJET index convention)
18377       CHARACTER*8  ANAME
18378       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18379      &                IICH(210),IIBAR(210),K1(210),K2(210)
18380
18381       DIMENSION PPROJ(5),PNUC(5)
18382
18383       DATA LSTART /.TRUE./
18384
18385       IREJ   = 0
18386
18387       NPOINT(1) = NHKK+1
18388
18389       TAUSAV = TAUFOR
18390 **sr 6/9/01 commented
18391 C     TAUFOR = TAUFOR/2.0D0
18392 **
18393       IF (LSTART) THEN
18394          WRITE(LOUT,1000)
18395  1000    FORMAT(/,1X,'HADCOL:  Scattering handled by HADRIN')
18396          WRITE(LOUT,1001) TAUFOR
18397  1001    FORMAT(/,1X,'HADCOL:  Formation zone parameter set to ',
18398      &          F5.1,' fm/c')
18399          LSTART = .FALSE.
18400       ENDIF
18401
18402       IDNUC  = IDBAM(IDXTAR)
18403       IDNUC1 = IDT_MCHAD(IDNUC)
18404       IDPRO1 = IDT_MCHAD(IDPROJ)
18405
18406       IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
18407          IPROC = INTHAD
18408       ELSE
18409 **
18410 C        CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
18411 C        CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
18412          DUMZER = ZERO
18413          CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
18414          SIGIN = SIGTOT-SIGEL
18415 C        SIGTOT = SIGIN+SIGEL
18416 **
18417          IPROC  = 1
18418          IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
18419       ENDIF
18420
18421       PPROJ(1) = ZERO
18422       PPROJ(2) = ZERO
18423       PPROJ(3) = PPN
18424       PPROJ(5) = AAM(IDPROJ)
18425       PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
18426       DO 1 K=1,5
18427          PNUC(K)  = PHKK(K,IDXTAR)
18428     1 CONTINUE
18429
18430       ILOOP = 0
18431     2 CONTINUE
18432       ILOOP = ILOOP+1
18433       IF (ILOOP.GT.100) GOTO 9999
18434
18435       CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
18436       IF (IREJ1.EQ.1) GOTO 9999
18437
18438       IF (IREJ1.GT.1) THEN
18439 * no interaction possible
18440 *   require Pauli blocking
18441          IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
18442          IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
18443          IF ((IIBAR(IDPROJ).NE.1).AND.
18444      &       (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5)))              GOTO 2
18445 *   store incoming particle as final state particle
18446          CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
18447          CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
18448          NPOINT(4) = NHKK
18449       ELSE
18450 * require Pauli blocking for final state nucleons
18451          DO 4 I=1,NFSP
18452             IF ((IDFSP(I).EQ.1).AND.
18453      &          (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I))))       GOTO 2
18454             IF ((IDFSP(I).EQ.8).AND.
18455      &          (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I))))       GOTO 2
18456             IF ((IIBAR(IDFSP(I)).NE.1).AND.
18457      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
18458     4    CONTINUE
18459 * store final state particles
18460          DO 5 I=1,NFSP
18461             IST = 1
18462             IF ((IIBAR(IDFSP(I)).EQ.1).AND.
18463      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
18464             IDHAD = IDT_IPDGHA(IDFSP(I))
18465             CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
18466             CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
18467      &                                        PCMS,ECMS,0,0,0)
18468             IF (I.EQ.1) NPOINT(4) = NHKK
18469             VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
18470             VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
18471             VHKK(3,NHKK) = VHKK(3,IDXTAR)
18472             VHKK(4,NHKK) = VHKK(4,IDXTAR)
18473             WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
18474             WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
18475             WHKK(3,NHKK) = WHKK(3,1)
18476             WHKK(4,NHKK) = WHKK(4,1)
18477     5    CONTINUE
18478       ENDIF
18479       TAUFOR = TAUSAV
18480       RETURN
18481
18482  9999 CONTINUE
18483       IREJ = 1
18484       TAUFOR = TAUSAV
18485       RETURN
18486       END
18487 *$ CREATE DT_GETEMU.FOR
18488 *COPY DT_GETEMU
18489 *
18490 *===getemu=============================================================*
18491 *
18492       SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
18493
18494 ************************************************************************
18495 * Sampling of emulsion component to be considered as target-nucleus.   *
18496 * This version dated 6.5.95   is written by S. Roesler.                *
18497 ************************************************************************
18498
18499       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18500       SAVE
18501
18502       PARAMETER ( LINP = 10 ,
18503      &            LOUT = 6 ,
18504      &            LDAT = 9 )
18505
18506       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18507
18508       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
18509
18510 * emulsion treatment
18511       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
18512      &                NCOMPO,IEMUL
18513
18514 * Glauber formalism: flags and parameters for statistics
18515       LOGICAL LPROD
18516       CHARACTER*8 CGLB
18517       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
18518
18519       IF (MODE.EQ.0) THEN
18520          SUMFRA = ZERO
18521          RR = DT_RNDM(SUMFRA)
18522          IT  = 0
18523          ITZ = 0
18524          DO 1 ICOMP=1,NCOMPO
18525             SUMFRA = SUMFRA+EMUFRA(ICOMP)
18526             IF (SUMFRA.GT.RR) THEN
18527                IT    = IEMUMA(ICOMP)
18528                ITZ   = IEMUCH(ICOMP)
18529                KKMAT = ICOMP
18530                GOTO 2
18531             ENDIF
18532     1    CONTINUE
18533     2    CONTINUE
18534          IF (IT.LE.0) THEN
18535             WRITE(LOUT,'(1X,A,E12.3)')
18536      &       'Warning!  norm. failure within emulsion fractions',
18537      &       SUMFRA
18538             STOP
18539          ENDIF
18540       ELSEIF (MODE.EQ.1) THEN
18541          NDIFF = 10000
18542          DO 3 I=1,NCOMPO
18543             IDIFF = ABS(IT-IEMUMA(I))
18544             IF (IDIFF.LT.NDIFF) THEN
18545                KKMAT = I
18546                NDIFF = IDIFF
18547             ENDIF
18548     3    CONTINUE
18549       ELSE
18550          STOP 'DT_GETEMU'
18551       ENDIF
18552
18553 * bypass for variable projectile/target/energy runs: the correct
18554 * Glauber data will be always loaded on kkmat=1
18555       IF (IOGLB.EQ.100) THEN
18556          KKMAT = 1
18557       ENDIF
18558
18559       RETURN
18560       END
18561
18562 *$ CREATE DT_NCLPOT.FOR
18563 *COPY DT_NCLPOT
18564 *
18565 *===nclpot=============================================================*
18566 *
18567       SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
18568
18569 ************************************************************************
18570 * Calculation of Coulomb and nuclear potential for a given configurat. *
18571 *               IPZ, IP       charge/mass number of proj.              *
18572 *               ITZ, IT       charge/mass number of targ.              *
18573 *               AFERP,AFERT   factors modifying proj./target pot.      *
18574 *                             if =0, FERMOD is used                    *
18575 *               MODE = 0      calculation of binding energy            *
18576 *                    = 1      pre-calculated binding energy is used    *
18577 * This version dated 16.11.95  is written by S. Roesler.               *
18578 *                                                                      *
18579 * Last change 28.12.2006 by S. Roesler.                                *
18580 ************************************************************************
18581
18582       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18583       SAVE
18584
18585       PARAMETER ( LINP = 10 ,
18586      &            LOUT = 6 ,
18587      &            LDAT = 9 )
18588
18589       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18590      &           TINY10=1.0D-10)
18591
18592       LOGICAL LSTART
18593
18594 * particle properties (BAMJET index convention)
18595       CHARACTER*8  ANAME
18596       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18597      &                IICH(210),IIBAR(210),K1(210),K2(210)
18598
18599 * nuclear potential
18600       LOGICAL LFERMI
18601       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18602      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18603      &                ETACOU(2),ICOUL,LFERMI
18604
18605       DIMENSION IDXPOT(14)
18606 *                   ap   an  lam  alam sig- sig+ sig0 tet0 tet- asig-
18607       DATA IDXPOT /   2,   9,  17,  18,  20,  21,  22,  97,  98,  99,
18608 *                 asig0 asig+ atet0 atet+
18609      &              100, 101, 102, 103/
18610
18611       DATA AN     /0.4D0/
18612       DATA LSTART /.TRUE./
18613
18614       IF (MODE.EQ.0) THEN
18615          EBINDP(1) = ZERO
18616          EBINDN(1) = ZERO
18617          EBINDP(2) = ZERO
18618          EBINDN(2) = ZERO
18619       ENDIF
18620       AIP  = DBLE(IP)
18621       AIPZ = DBLE(IPZ)
18622       AIT  = DBLE(IT)
18623       AITZ = DBLE(ITZ)
18624
18625       FERMIP = AFERP
18626       IF (AFERP.LE.ZERO) FERMIP = FERMOD
18627       FERMIT = AFERT
18628       IF (AFERT.LE.ZERO) FERMIT = FERMOD
18629
18630 * Fermi momenta and binding energy for projectile
18631       IF ((IP.GT.1).AND.LFERMI) THEN
18632          IF (MODE.EQ.0) THEN
18633 C           EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
18634 C           EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
18635             BIP  = AIP -ONE
18636             BIPZ = AIPZ-ONE
18637
18638 C           EBINDP(1) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIP,BIPZ)
18639 C    &                                         -ENERGY(AIP,AIPZ))
18640             EBINDP(1) = 1.0D-3*(EXMSAZ(ONE,ONE ,.TRUE.,IZDUM)
18641      &                         +EXMSAZ(BIP,BIPZ,.TRUE.,IZDUM)
18642      &                         -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18643
18644             IF (AIP.LE.AIPZ) THEN
18645                EBINDN(1) = EBINDP(1)
18646                WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
18647             ELSE
18648
18649 C              EBINDN(1) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIP,AIPZ)
18650 C    &                                             -ENERGY(AIP,AIPZ))
18651                EBINDN(1) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18652      &                            +EXMSAZ(BIP,AIPZ,.TRUE.,IZDUM)
18653      &                            -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18654
18655             ENDIF
18656          ENDIF
18657          PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
18658          PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
18659       ELSE
18660          PFERMP(1) = ZERO
18661          PFERMN(1) = ZERO
18662       ENDIF
18663 * effective nuclear potential for projectile
18664 C     EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
18665 C     EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
18666       EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
18667       EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
18668
18669 * Fermi momenta and binding energy for target
18670       IF ((IT.GT.1).AND.LFERMI) THEN
18671          IF (MODE.EQ.0) THEN
18672 C           EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
18673 C           EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
18674             BIT  = AIT -ONE
18675             BITZ = AITZ-ONE
18676
18677 C           EBINDP(2) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIT,BITZ)
18678 C    &                                         -ENERGY(AIT,AITZ))
18679             EBINDP(2) = 1.0D-3*(EXMSAZ(ONE,ONE, .TRUE.,IZDUM)
18680      &                         +EXMSAZ(BIT,BITZ,.TRUE.,IZDUM)
18681      &                         -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18682
18683             IF (AIT.LE.AITZ) THEN
18684                EBINDN(2) = EBINDP(2)
18685                WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
18686             ELSE
18687
18688 C              EBINDN(2) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIT,AITZ)
18689 C    &                                             -ENERGY(AIT,AITZ))
18690                EBINDN(2) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18691      &                            +EXMSAZ(BIT,AITZ,.TRUE.,IZDUM)
18692      &                            -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18693
18694             ENDIF
18695          ENDIF
18696          PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
18697          PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
18698       ELSE
18699          PFERMP(2) = ZERO
18700          PFERMN(2) = ZERO
18701       ENDIF
18702 * effective nuclear potential for target
18703 C     EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
18704 C     EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
18705       EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
18706       EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
18707
18708       DO 2 I=1,14
18709          EPOT(1,IDXPOT(I)) = EPOT(1,8)
18710          EPOT(2,IDXPOT(I)) = EPOT(2,8)
18711     2 CONTINUE
18712
18713 * Coulomb energy
18714       ETACOU(1) = ZERO
18715       ETACOU(2) = ZERO
18716       IF (ICOUL.EQ.1) THEN
18717          IF (IP.GT.1)
18718      &   ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
18719          IF (IT.GT.1)
18720      &   ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
18721       ENDIF
18722
18723       IF (LSTART) THEN
18724          WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
18725      &                    EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
18726      &                    EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
18727      &                    FERMOD,ETACOU
18728  1000    FORMAT(/,/,1X,'NCLPOT:    quantities for inclusion of nuclear'
18729      &           ,' effects',/,12X,'---------------------------',
18730      &           '----------------',/,/,38X,'projectile',
18731      &           '      target',/,/,1X,'Mass number / charge',
18732      &           17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy  -',
18733      &           ' proton   (GeV) ',2E14.4,/,17X,'- neutron  (GeV)'
18734      &          ,1X,2E14.4,/,1X,'Fermi-potential - proton   (GeV)',
18735      &           1X,2E14.4,/,17X,'- neutron  (GeV) ',2E14.4,/,/,
18736      &           1X,'Scale factor for Fermi-momentum    ',F4.2,/,
18737      &           /,1X,'Coulomb-energy ',2(E14.4,' GeV  '),/,/)
18738          LSTART = .FALSE.
18739       ENDIF
18740
18741       RETURN
18742       END
18743
18744 *$ CREATE DT_RESNCL.FOR
18745 *COPY DT_RESNCL
18746 *
18747 *===resncl=============================================================*
18748 *
18749       SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
18750
18751 ************************************************************************
18752 * Treatment of residual nuclei and nuclear effects.                    *
18753 *         MODE = 1     initializations                                 *
18754 *              = 2     treatment of final state                        *
18755 * This version dated 16.11.95 is written by S. Roesler.                *
18756 *                                                                      *
18757 * Last change 05.01.2007 by S. Roesler.                                *
18758 ************************************************************************
18759
18760       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18761       SAVE
18762
18763       PARAMETER ( LINP = 10 ,
18764      &            LOUT = 6 ,
18765      &            LDAT = 9 )
18766
18767       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
18768      &           TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
18769      &           ONETHI=ONE/THREE)
18770       PARAMETER (AMUAMU = 0.93149432D0,
18771      &           FM2MM  = 1.0D-12,
18772      &           RNUCLE = 1.12D0)
18773       PARAMETER ( EMVGEV = 1.0                D-03 )
18774       PARAMETER ( AMUGEV = 0.93149432         D+00 )
18775       PARAMETER ( AMPRTN = 0.93827231         D+00 )
18776       PARAMETER ( AMNTRN = 0.93956563         D+00 )
18777       PARAMETER ( AMELCT = 0.51099906         D-03 )
18778       PARAMETER ( HLFHLF = 0.5D+00 )
18779       PARAMETER ( FERTHO = 14.33       D-09 )
18780       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
18781       PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
18782       PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
18783
18784 * event history
18785
18786       PARAMETER (NMXHKK=200000)
18787
18788       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18789      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18790      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18791
18792 * extended event history
18793       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18794      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18795      &                IHIST(2,NMXHKK)
18796
18797 * particle properties (BAMJET index convention)
18798       CHARACTER*8  ANAME
18799       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18800      &                IICH(210),IIBAR(210),K1(210),K2(210)
18801
18802 * flags for input different options
18803       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18804       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18805      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18806
18807 * nuclear potential
18808       LOGICAL LFERMI
18809       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18810      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18811      &                ETACOU(2),ICOUL,LFERMI
18812
18813 * properties of interacting particles
18814       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18815
18816 * properties of photon/lepton projectiles
18817       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
18818
18819 * Lorentz-parameters of the current interaction
18820       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
18821      &                UMO,PPCM,EPROJ,PPROJ
18822
18823 * treatment of residual nuclei: wounded nucleons
18824       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18825
18826 * treatment of residual nuclei: 4-momenta
18827       LOGICAL LRCLPR,LRCLTA
18828       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18829      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18830
18831       DIMENSION PFSP(4),PSEC(4),PSEC0(4)
18832       DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
18833      &          IDXCOR(15000),IDXOTH(NMXHKK)
18834
18835       GOTO (1,2) MODE
18836
18837 *------- initializations
18838     1 CONTINUE
18839
18840 * initialize arrays for residual nuclei
18841       DO 10 K=1,5
18842          IF (K.LE.4) THEN
18843             PFSP(K)     = ZERO
18844          ENDIF
18845          PINIPR(K) = ZERO
18846          PINITA(K) = ZERO
18847          PRCLPR(K) = ZERO
18848          PRCLTA(K) = ZERO
18849          TRCLPR(K) = ZERO
18850          TRCLTA(K) = ZERO
18851    10 CONTINUE
18852       SCPOT = ONE
18853       NLOOP = 0
18854
18855 * correction of projectile 4-momentum for effective target pot.
18856 * and Coulomb-energy (in case of hadron-nucleus interaction only)
18857       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18858          EPNI = EPN
18859 *   Coulomb-energy:
18860 *     positively charged hadron - check energy for Coloumb pot.
18861          IF (IICH(IJPROJ).EQ.1) THEN
18862             THRESH = ETACOU(2)+AAM(IJPROJ)
18863             IF (EPNI.LE.THRESH) THEN
18864                WRITE(LOUT,1000)
18865  1000          FORMAT(/,1X,'KKINC:  WARNING!  projectile energy',
18866      &                ' below Coulomb threshold - event rejected',/)
18867                ISTHKK(1) = 1
18868                RETURN
18869             ENDIF
18870 *     negatively charged hadron - increase energy by Coulomb energy
18871          ELSEIF (IICH(IJPROJ).EQ.-1) THEN
18872             EPNI = EPNI+ETACOU(2)
18873          ENDIF
18874          IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
18875 *   Effective target potential
18876 *sr 6.6. binding energy only (to avoid negative exc. energies)
18877 C           EPNI = EPNI+EPOT(2,IJPROJ)
18878             EBIPOT = EBINDP(2)
18879             IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
18880      &         EBIPOT = EBINDN(2)
18881             EPNI = EPNI+ABS(EBIPOT)
18882 * re-initialization of DTLTRA
18883             DUM1 = ZERO
18884             DUM2 = ZERO
18885             CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
18886          ENDIF
18887       ENDIF
18888
18889 * projectile in n-n cms
18890       IF ((IP.LE.1).AND.(IT.GT.1)) THEN
18891          PMASS1 = AAM(IJPROJ)
18892 C* VDM assumption
18893 C         IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
18894          IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
18895          PMASS2 = AAM(1)
18896          PM1 = SIGN(PMASS1**2,PMASS1)
18897          PM2 = SIGN(PMASS2**2,PMASS2)
18898          PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
18899          PINIPR(5) = PMASS1
18900          IF (PMASS1.GT.ZERO) THEN
18901             PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
18902      &                      *(PINIPR(4)+PINIPR(5)))
18903          ELSE
18904             PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
18905          ENDIF
18906          AIT  = DBLE(IT)
18907          AITZ = DBLE(ITZ)
18908
18909 C        PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18910          PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18911
18912          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18913       ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
18914          PMASS1 = AAM(1)
18915          PMASS2 = AAM(IJTARG)
18916          PM1 = SIGN(PMASS1**2,PMASS1)
18917          PM2 = SIGN(PMASS2**2,PMASS2)
18918          PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
18919          PINITA(5) = PMASS2
18920          PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18921      &                    *(PINITA(4)+PINITA(5)))
18922          AIP  = DBLE(IP)
18923          AIPZ = DBLE(IPZ)
18924
18925 C        PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18926          PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18927
18928          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18929       ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18930          AIP  = DBLE(IP)
18931          AIPZ = DBLE(IPZ)
18932
18933 C        PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18934          PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18935
18936          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18937          AIT  = DBLE(IT)
18938          AITZ = DBLE(ITZ)
18939
18940 C        PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18941          PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18942
18943          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18944       ENDIF
18945
18946       RETURN
18947
18948 *------- treatment of final state
18949     2 CONTINUE
18950
18951       NLOOP = NLOOP+1
18952       IF (NLOOP.GT.1) SCPOT = 0.10D0
18953 C     WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18954
18955       JPW  = NPW
18956       JPCW = NPCW
18957       JTW  = NTW
18958       JTCW = NTCW
18959       DO 40 K=1,4
18960          PFSP(K)   = ZERO
18961    40 CONTINUE
18962
18963       NOB = 0
18964       NOM = 0
18965       DO 900 I=NPOINT(4),NHKK
18966          IDXOTH(I) = -1
18967          IF (ISTHKK(I).EQ.1) THEN
18968             IF (IDBAM(I).EQ.7) GOTO 900
18969             IPOT = 0
18970             IOTHER = 0
18971 * particle moving into forward direction
18972             IF (PHKK(3,I).GE.ZERO) THEN
18973 *   most likely to be effected by projectile potential
18974                IPOT = 1
18975 *     there is no projectile nucleus, try target
18976                IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18977                   IPOT   = 2
18978                   IF (IP.GT.1) IOTHER = 1
18979 *       there is no target nucleus --> skip
18980                   IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18981                ENDIF
18982 * particle moving into backward direction
18983             ELSE
18984 *   most likely to be effected by target potential
18985                IPOT = 2
18986 *     there is no target nucleus, try projectile
18987                IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18988                   IPOT   = 1
18989                   IF (IT.GT.1) IOTHER = 1
18990 *       there is no projectile nucleus --> skip
18991                   IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18992                ENDIF
18993             ENDIF
18994             IFLG = -IPOT
18995 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18996 *      =1: particle is not in overlap-region AND is inside target (2)
18997 *      =2: particle is not in overlap-region AND is inside projectile (1)
18998 * flag particles which are inside the nucleus ipot but not in its
18999 * overlap region
19000             IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
19001             IF (IDBAM(I).NE.0) THEN
19002 * baryons: keep all nucleons and all others where flag is set
19003                IF (IIBAR(IDBAM(I)).NE.0) THEN
19004                   IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
19005      &                                                              THEN
19006                      NOB = NOB+1
19007                      PMOMB(NOB) = PHKK(3,I)
19008                      IDXB(NOB)  = SIGN(10000000*IABS(IFLG)
19009      &                           +1000000*IOTHER+I,IFLG)
19010                   ENDIF
19011 * mesons: keep only those mesons where flag is set
19012                ELSE
19013                   IF (IFLG.GT.0) THEN
19014                      NOM = NOM+1
19015                      PMOMM(NOM) = PHKK(3,I)
19016                      IDXM(NOM)  = 10000000*IFLG+1000000*IOTHER+I
19017                   ENDIF
19018                ENDIF
19019             ENDIF
19020          ENDIF
19021   900 CONTINUE
19022 *
19023 * sort particles in the arrays according to increasing long. momentum
19024       CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
19025       CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
19026 *
19027 * shuffle indices into one and the same array according to the later
19028 * sequence of correction
19029       NCOR = 0
19030       IF (IT.GT.1) THEN
19031          DO 910 I=1,NOB
19032             IF (PMOMB(I).GT.ZERO) GOTO 911
19033             NCOR = NCOR+1
19034             IDXCOR(NCOR) = IDXB(I)
19035   910    CONTINUE
19036   911    CONTINUE
19037          IF (IP.GT.1) THEN
19038             DO 912 J=1,NOB
19039                I = NOB+1-J
19040                IF (PMOMB(I).LT.ZERO) GOTO 913
19041                NCOR = NCOR+1
19042                IDXCOR(NCOR) = IDXB(I)
19043   912       CONTINUE
19044   913       CONTINUE
19045          ELSE
19046             DO 914 I=1,NOB
19047                IF (PMOMB(I).GT.ZERO) THEN
19048                   NCOR = NCOR+1
19049                   IDXCOR(NCOR) = IDXB(I)
19050                ENDIF
19051   914       CONTINUE
19052          ENDIF
19053       ELSE
19054          DO 915 J=1,NOB
19055             I = NOB+1-J
19056             NCOR = NCOR+1
19057             IDXCOR(NCOR) = IDXB(I)
19058   915    CONTINUE
19059       ENDIF
19060       DO 925 I=1,NOM
19061          IF (PMOMM(I).GT.ZERO) GOTO 926
19062          NCOR = NCOR+1
19063          IDXCOR(NCOR) = IDXM(I)
19064   925 CONTINUE
19065   926 CONTINUE
19066       DO 927 J=1,NOM
19067          I = NOM+1-J
19068          IF (PMOMM(I).LT.ZERO) GOTO 928
19069          NCOR = NCOR+1
19070          IDXCOR(NCOR) = IDXM(I)
19071   927 CONTINUE
19072   928 CONTINUE
19073 *
19074 C      IF (NEVHKK.EQ.484) THEN
19075 C         WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
19076 C 9000    FORMAT(1X,'wounded nucleons (proj.-p,n  targ.-p,n)',/,4I10)
19077 C         WRITE(LOUT,9001) NOB,NOM,NCOR
19078 C 9001    FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
19079 C         WRITE(LOUT,'(/,A)') ' baryons '
19080 C         DO 950 I=1,NOB
19081 CC           J     = IABS(IDXB(I))
19082 CC           INDEX = J-IABS(J/10000000)*10000000
19083 C            IPOT   = IABS(IDXB(I))/10000000
19084 C            IOTHER = IABS(IDXB(I))/1000000-IPOT*10
19085 C            INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
19086 C            WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
19087 C  950    CONTINUE
19088 C         WRITE(LOUT,'(/,A)') ' mesons '
19089 C         DO 951 I=1,NOM
19090 CC           INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
19091 C            IPOT   = IABS(IDXM(I))/10000000
19092 C            IOTHER = IABS(IDXM(I))/1000000-IPOT*10
19093 C            INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
19094 C            WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
19095 C  951    CONTINUE
19096 C 9002    FORMAT(1X,4I14,E14.5)
19097 C         WRITE(LOUT,'(/,A)') ' all '
19098 C         DO 952 I=1,NCOR
19099 CC           J     = IABS(IDXCOR(I))
19100 CC           INDEX = J-IABS(J/10000000)*10000000
19101 CC            IPOT   = IABS(IDXCOR(I))/10000000
19102 C            IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
19103 C            INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
19104 C            WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
19105 C  952    CONTINUE
19106 C 9003    FORMAT(1X,4I14)
19107 C      ENDIF
19108 *
19109       DO 20 ICOR=1,NCOR
19110          IPOT   = IABS(IDXCOR(ICOR))/10000000
19111          IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
19112          I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
19113          IDXOTH(I) = 1
19114
19115          IDSEC  = IDBAM(I)
19116
19117 * reduction of particle momentum by corresponding nuclear potential
19118 * (this applies only if Fermi-momenta are requested)
19119
19120          IF (LFERMI) THEN
19121
19122 *   Lorentz-transformation into the rest system of the selected nucleus
19123             IMODE = -IPOT-1
19124             CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19125      &                  PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
19126             PSECO  = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
19127             AMSEC  = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
19128             JPMOD  = 0
19129
19130             CHKLEV = TINY3
19131             IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
19132             IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
19133             IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
19134                IF (IOULEV(3).GT.0)
19135      &            WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
19136  2000          FORMAT(1X,'RESNCL: inconsistent mass of particle',
19137      &                ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
19138      &                I4,'   AMSEC: ',E12.3,'  AAM(IDSEC): ',E12.3,/)
19139                GOTO 23
19140             ENDIF
19141
19142             DO 21 K=1,4
19143                PSEC0(K) = PSEC(K)
19144    21       CONTINUE
19145
19146 *   the correction for nuclear potential effects is applied to as many
19147 *   p/n as many nucleons were wounded; the momenta of other final state
19148 *   particles are corrected only if they materialize inside the corresp.
19149 *   nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
19150 *   = 3 part. outside proj. and targ., >=10 in overlapping region)
19151             IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
19152                IF (IPOT.EQ.1) THEN
19153                   IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
19154 *      this is most likely a wounded nucleon
19155 **test
19156 C                    RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
19157 C    &                           +(VHKK(2,IPW(JPW))/FM2MM)**2
19158 C    &                           +(VHKK(3,IPW(JPW))/FM2MM)**2)
19159 C                    RAD   = RNUCLE*DBLE(IP)**ONETHI
19160 C                    FDEN  = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
19161 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19162 **
19163                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19164                      JPW = JPW-1
19165                      JPMOD = 1
19166                   ELSE
19167 *      correct only if part. was materialized inside nucleus
19168 *      and if it is ouside the overlapping region
19169                      IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
19170                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19171                         JPMOD = 1
19172                      ENDIF
19173                   ENDIF
19174                ELSEIF (IPOT.EQ.2) THEN
19175                   IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
19176 *      this is most likely a wounded nucleon
19177 **test
19178 C                    RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
19179 C    &                           +(VHKK(2,ITW(JTW))/FM2MM)**2
19180 C    &                           +(VHKK(3,ITW(JTW))/FM2MM)**2)
19181 C                    RAD   = RNUCLE*DBLE(IT)**ONETHI
19182 C                    FDEN  = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
19183 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19184 **
19185                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19186                      JTW = JTW-1
19187                      JPMOD = 1
19188                   ELSE
19189 *      correct only if part. was materialized inside nucleus
19190                      IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
19191                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19192                         JPMOD = 1
19193                      ENDIF
19194                   ENDIF
19195                ENDIF
19196             ELSE
19197                IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
19198                   PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19199                   JPMOD = 1
19200                ENDIF
19201             ENDIF
19202
19203             IF (NLOOP.EQ.1) THEN
19204 * Coulomb energy correction:
19205 * the treatment of Coulomb potential correction is similar to the
19206 * one for nuclear potential
19207                IF (IDSEC.EQ.1) THEN
19208                   IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
19209                      JPCW = JPCW-1
19210                   ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
19211                      JTCW = JTCW-1
19212                   ELSE
19213                      IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19214                   ENDIF
19215                ELSE
19216                   IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19217                ENDIF
19218                IF (IICH(IDSEC).EQ.1) THEN
19219 *    pos. particles: check if they are able to escape Coulomb potential
19220                   IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
19221                      ISTHKK(I) = 14+IPOT
19222                      IF (ISTHKK(I).EQ.15) THEN
19223                         DO 26 K=1,4
19224                            PHKK(K,I) = PSEC0(K)
19225                            TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19226    26                CONTINUE
19227                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19228                         IF (IDSEC.EQ.1) NPCW = NPCW-1
19229                      ELSEIF (ISTHKK(I).EQ.16) THEN
19230                         DO 27 K=1,4
19231                            PHKK(K,I) = PSEC0(K)
19232                            TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19233    27                   CONTINUE
19234                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19235                         IF (IDSEC.EQ.1) NTCW = NTCW-1
19236                      ENDIF
19237                      GOTO 20
19238                   ENDIF
19239                ELSEIF (IICH(IDSEC).EQ.-1) THEN
19240 *    neg. particles: decrease energy by Coulomb-potential
19241                   PSEC(4) = PSEC(4)-ETACOU(IPOT)
19242                   JPMOD = 1
19243                ENDIF
19244             ENDIF
19245
19246    25       CONTINUE
19247
19248             IF (PSEC(4).LT.AMSEC) THEN
19249                IF (IOULEV(6).GT.0)
19250      &            WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
19251  2001          FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
19252      &                ' is not allowed to escape nucleus',/,
19253      &                8X,'id : ',I3,'   reduced energy: ',E15.4,
19254      &                '   mass: ',E12.3)
19255                ISTHKK(I) = 14+IPOT
19256                IF (ISTHKK(I).EQ.15) THEN
19257                   DO 28 K=1,4
19258                      PHKK(K,I) = PSEC0(K)
19259                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19260    28             CONTINUE
19261                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19262                   IF (IDSEC.EQ.1) NPCW = NPCW-1
19263                ELSEIF (ISTHKK(I).EQ.16) THEN
19264                   DO 29 K=1,4
19265                      PHKK(K,I) = PSEC0(K)
19266                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19267    29             CONTINUE
19268                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19269                   IF (IDSEC.EQ.1) NTCW = NTCW-1
19270                ENDIF
19271                GOTO 20
19272             ENDIF
19273
19274             IF (JPMOD.EQ.1) THEN
19275                PSECN  = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
19276 * 4-momentum after correction for nuclear potential
19277                DO 22 K=1,3
19278                   PSEC(K) = PSEC(K)*PSECN/PSECO
19279    22          CONTINUE
19280
19281 * store recoil momentum from particles escaping the nuclear potentials
19282                DO 30 K=1,4
19283                   IF (IPOT.EQ.1) THEN
19284                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
19285                   ELSEIF (IPOT.EQ.2) THEN
19286                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
19287                   ENDIF
19288    30          CONTINUE
19289
19290 * transform momentum back into n-n cms
19291                IMODE = IPOT+1
19292                CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
19293      &                     PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19294      &                     IDSEC,IMODE)
19295             ENDIF
19296
19297          ENDIF
19298
19299    23    CONTINUE
19300          DO 31 K=1,4
19301             PFSP(K) = PFSP(K)+PHKK(K,I)
19302    31    CONTINUE
19303
19304    20 CONTINUE
19305
19306       DO 33 I=NPOINT(4),NHKK
19307          IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
19308             PFSP(1) = PFSP(1)+PHKK(1,I)
19309             PFSP(2) = PFSP(2)+PHKK(2,I)
19310             PFSP(3) = PFSP(3)+PHKK(3,I)
19311             PFSP(4) = PFSP(4)+PHKK(4,I)
19312          ENDIF
19313    33 CONTINUE
19314
19315       DO 34 K=1,5
19316          PRCLPR(K) = TRCLPR(K)
19317          PRCLTA(K) = TRCLTA(K)
19318    34 CONTINUE
19319
19320       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
19321 * hadron-nucleus interactions: get residual momentum from energy-
19322 * momentum conservation
19323          DO 32 K=1,4
19324             PRCLPR(K) = ZERO
19325             PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
19326    32    CONTINUE
19327       ELSE
19328 * nucleus-hadron, nucleus-nucleus: get residual momentum from
19329 * accumulated recoil momenta of particles leaving the spectators
19330 *   transform accumulated recoil momenta of residual nuclei into
19331 *   n-n cms
19332          PZI = PRCLPR(3)
19333          PEI = PRCLPR(4)
19334          CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
19335          PZI = PRCLTA(3)
19336          PEI = PRCLTA(4)
19337          CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
19338 C        IF (IP.GT.1) THEN
19339             PRCLPR(3) = PRCLPR(3)+PINIPR(3)
19340             PRCLPR(4) = PRCLPR(4)+PINIPR(4)
19341 C        ENDIF
19342          IF (IT.GT.1) THEN
19343             PRCLTA(3) = PRCLTA(3)+PINITA(3)
19344             PRCLTA(4) = PRCLTA(4)+PINITA(4)
19345          ENDIF
19346       ENDIF
19347
19348 * check momenta of residual nuclei
19349       IF (LEMCCK) THEN
19350          CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
19351      &               1,IDUM,IDUM)
19352          CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
19353      &               2,IDUM,IDUM)
19354          CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
19355      &               2,IDUM,IDUM)
19356          CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
19357      &               2,IDUM,IDUM)
19358          CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
19359 **sr 19.12. changed to avoid output when used with phojet
19360 C        CHKLEV = TINY3
19361          CHKLEV = TINY1
19362          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
19363 C        IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
19364 C    &      CALL DT_EVTOUT(4)
19365          IF (IREJ1.GT.0) RETURN
19366       ENDIF
19367
19368       RETURN
19369       END
19370
19371 *$ CREATE DT_SCN4BA.FOR
19372 *COPY DT_SCN4BA
19373 *
19374 *===scn4ba=============================================================*
19375 *
19376       SUBROUTINE DT_SCN4BA
19377
19378 ************************************************************************
19379 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot.    *
19380 * This version dated 12.12.95 is written by S. Roesler.                *
19381 ************************************************************************
19382
19383       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19384       SAVE
19385
19386       PARAMETER ( LINP = 10 ,
19387      &            LOUT = 6 ,
19388      &            LDAT = 9 )
19389
19390       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
19391      &           TINY10=1.0D-10)
19392
19393 * event history
19394
19395       PARAMETER (NMXHKK=200000)
19396
19397       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19398      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19399      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19400
19401 * extended event history
19402       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19403      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19404      &                IHIST(2,NMXHKK)
19405
19406 * particle properties (BAMJET index convention)
19407       CHARACTER*8  ANAME
19408       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19409      &                IICH(210),IIBAR(210),K1(210),K2(210)
19410
19411 * properties of interacting particles
19412       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
19413
19414 * nuclear potential
19415       LOGICAL LFERMI
19416       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
19417      &                EBINDP(2),EBINDN(2),EPOT(2,210),
19418      &                ETACOU(2),ICOUL,LFERMI
19419
19420 * treatment of residual nuclei: wounded nucleons
19421       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
19422
19423 * treatment of residual nuclei: 4-momenta
19424       LOGICAL LRCLPR,LRCLTA
19425       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19426      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19427
19428       DIMENSION PLAB(2,5),PCMS(4)
19429
19430       IREJ = 0
19431
19432 * get number of wounded nucleons
19433       NPW    = 0
19434       NPW0   = 0
19435       NPCW   = 0
19436       NPSTCK = 0
19437       NTW    = 0
19438       NTW0   = 0
19439       NTCW   = 0
19440       NTSTCK = 0
19441
19442       ISGLPR = 0
19443       ISGLTA = 0
19444       LRCLPR = .FALSE.
19445       LRCLTA = .FALSE.
19446
19447 C     DO 2 I=1,NHKK
19448       DO 2 I=1,NPOINT(1)
19449 * projectile nucleons wounded in primary interaction and in fzc
19450          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
19451             NPW      = NPW+1
19452             IPW(NPW) = I
19453             NPSTCK   = NPSTCK+1
19454             IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
19455             IF (ISTHKK(I).EQ.11)  NPW0 = NPW0+1
19456 C           IF (IP.GT.1) THEN
19457                DO 5 K=1,4
19458                   TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
19459     5          CONTINUE
19460 C           ENDIF
19461 * target nucleons wounded in primary interaction and in fzc
19462          ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
19463             NTW      = NTW+1
19464             ITW(NTW) = I
19465             NTSTCK   = NTSTCK+1
19466             IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
19467             IF (ISTHKK(I).EQ.12)  NTW0 = NTW0+1
19468             IF (IT.GT.1) THEN
19469                DO 6 K=1,4
19470                   TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
19471     6          CONTINUE
19472             ENDIF
19473          ELSEIF (ISTHKK(I).EQ.13) THEN
19474             ISGLPR = I
19475          ELSEIF (ISTHKK(I).EQ.14) THEN
19476             ISGLTA = I
19477          ENDIF
19478     2 CONTINUE
19479
19480       DO 11 I=NPOINT(4),NHKK
19481 * baryons which are unable to escape the nuclear potential of proj.
19482          IF (ISTHKK(I).EQ.15) THEN
19483             ISGLPR = I
19484             NPSTCK = NPSTCK-1
19485             IF (IIBAR(IDBAM(I)).NE.0) THEN
19486                NPW    = NPW-1
19487                IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
19488             ENDIF
19489             DO 7 K=1,4
19490                TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19491     7       CONTINUE
19492 * baryons which are unable to escape the nuclear potential of targ.
19493          ELSEIF (ISTHKK(I).EQ.16) THEN
19494             ISGLTA = I
19495             NTSTCK = NTSTCK-1
19496             IF (IIBAR(IDBAM(I)).NE.0) THEN
19497                NTW    = NTW-1
19498                IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
19499             ENDIF
19500             DO 8 K=1,4
19501                TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19502     8       CONTINUE
19503          ENDIF
19504    11 CONTINUE
19505
19506 * residual nuclei so far
19507       IRESP = IP-NPSTCK
19508       IREST = IT-NTSTCK
19509
19510 * ckeck for "residual nuclei" consisting of one nucleon only
19511 * treat it as final state particle
19512       IF (IRESP.EQ.1) THEN
19513          ID  = IDBAM(ISGLPR)
19514          IST = ISTHKK(ISGLPR)
19515          CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
19516      &               PHKK(3,ISGLPR),PHKK(4,ISGLPR),
19517      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
19518          IF (IST.EQ.13) THEN
19519             ISTHKK(ISGLPR) = 11
19520          ELSE
19521             ISTHKK(ISGLPR) = 2
19522          ENDIF
19523          CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
19524      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19525      &               IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
19526          NOBAM(NHKK)      = NOBAM(ISGLPR)
19527          JDAHKK(1,ISGLPR) = NHKK
19528          DO 21 K=1,4
19529             TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
19530    21    CONTINUE
19531       ENDIF
19532       IF (IREST.EQ.1) THEN
19533          ID  = IDBAM(ISGLTA)
19534          IST = ISTHKK(ISGLTA)
19535          CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
19536      &               PHKK(3,ISGLTA),PHKK(4,ISGLTA),
19537      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
19538          IF (IST.EQ.14) THEN
19539             ISTHKK(ISGLTA) = 12
19540          ELSE
19541             ISTHKK(ISGLTA) = 2
19542          ENDIF
19543          CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
19544      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19545      &               IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
19546          NOBAM(NHKK)      = NOBAM(ISGLTA)
19547          JDAHKK(1,ISGLTA) = NHKK
19548          DO 22 K=1,4
19549             TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
19550    22    CONTINUE
19551       ENDIF
19552
19553 * get nuclear potential corresp. to the residual nucleus
19554       IPRCL  = IP -NPW
19555       IPZRCL = IPZ-NPCW
19556       ITRCL  = IT -NTW
19557       ITZRCL = ITZ-NTCW
19558       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
19559
19560 * baryons unable to escape the nuclear potential are treated as
19561 * excited nucleons (ISTHKK=15,16)
19562       DO 3 I=NPOINT(4),NHKK
19563          IF (ISTHKK(I).EQ.1) THEN
19564             ID  = IDBAM(I)
19565             IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
19566 *   final state n and p not being outside of both nuclei are considered
19567                NPOTP = 1
19568                NPOTT = 1
19569                IF ( (IP.GT.1)      .AND.(IRESP.GT.1).AND.
19570      &              (NOBAM(I).NE.1).AND.(NPW.GT.0)        ) THEN
19571 *     Lorentz-trsf. into proj. rest sys. for those being inside proj.
19572                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19573      &                        PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
19574      &                        PLAB(1,4),ID,-2)
19575                   PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
19576                   PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
19577      &                                  (PLAB(1,4)+PLABT) ))
19578                   EKIN = PLAB(1,4)-PLAB(1,5)
19579                   IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
19580                   IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
19581                ENDIF
19582                IF ( (IT.GT.1)      .AND.(IREST.GT.1).AND.
19583      &              (NOBAM(I).NE.2).AND.(NTW.GT.0)        ) THEN
19584 *     Lorentz-trsf. into targ. rest sys. for those being inside targ.
19585                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19586      &                        PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
19587      &                        PLAB(2,4),ID,-3)
19588                   PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
19589                   PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
19590      &                                  (PLAB(2,4)+PLABT) ))
19591                   EKIN = PLAB(2,4)-PLAB(2,5)
19592                   IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
19593                   IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
19594                ENDIF
19595                IF (PHKK(3,I).GE.ZERO) THEN
19596                   ISTHKK(I) = NPOTT
19597                   IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
19598                ELSE
19599                   ISTHKK(I) = NPOTP
19600                   IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
19601                ENDIF
19602                IF (ISTHKK(I).NE.1) THEN
19603                   J = ISTHKK(I)-14
19604                   DO 4 K=1,5
19605                      PHKK(K,I) = PLAB(J,K)
19606     4             CONTINUE
19607                   IF (ISTHKK(I).EQ.15) THEN
19608                      NPW = NPW-1
19609                      IF (ID.EQ.1) NPCW = NPCW-1
19610                      DO 9 K=1,4
19611                         TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19612     9                CONTINUE
19613                   ELSEIF (ISTHKK(I).EQ.16) THEN
19614                      NTW = NTW-1
19615                      IF (ID.EQ.1) NTCW = NTCW-1
19616                      DO 10 K=1,4
19617                         TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19618    10                CONTINUE
19619                   ENDIF
19620                ENDIF
19621             ENDIF
19622          ENDIF
19623     3 CONTINUE
19624
19625 * again: get nuclear potential corresp. to the residual nucleus
19626       IPRCL  = IP -NPW
19627       IPZRCL = IPZ-NPCW
19628       ITRCL  = IT -NTW
19629       ITZRCL = ITZ-NTCW
19630 c      AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
19631 cC     AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
19632 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
19633 C     AFERP = 0.0D0
19634 c      AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
19635 cC     AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
19636 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
19637 C     AFERT = 0.0D0
19638 C     IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
19639 C     IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
19640 C     IF (AFERP.GT.0.85D0) AFERP = 0.85D0
19641 C     IF (AFERT.GT.0.85D0) AFERT = 0.85D0
19642       AFERP = FERMOD+0.1D0
19643       AFERT = FERMOD+0.1D0
19644
19645       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
19646
19647       RETURN
19648       END
19649
19650 *$ CREATE DT_FICONF.FOR
19651 *COPY DT_FICONF
19652 *
19653 *===ficonf=============================================================*
19654 *
19655       SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
19656
19657 ************************************************************************
19658 * Treatment of FInal CONFiguration including evaporation, fission and  *
19659 * Fermi-break-up (for light nuclei only).                              *
19660 * Adopted from the original routine FINALE and extended to residual    *
19661 * projectile nuclei.                                                   *
19662 * This version dated 12.12.95 is written by S. Roesler.                *
19663 *                                                                      *
19664 * Last change 27.12.2006 by S. Roesler.                                *
19665 ************************************************************************
19666
19667       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19668       SAVE
19669
19670       PARAMETER ( LINP = 10 ,
19671      &            LOUT = 6 ,
19672      &            LDAT = 9 )
19673
19674       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
19675       PARAMETER (ANGLGB=5.0D-16)
19676
19677 * event history
19678
19679       PARAMETER (NMXHKK=200000)
19680
19681       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19682      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19683      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19684
19685 * extended event history
19686       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19687      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19688      &                IHIST(2,NMXHKK)
19689
19690 * rejection counter
19691       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
19692      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
19693      &                IREXCI(3),IRDIFF(2),IRINC
19694
19695 * central particle production, impact parameter biasing
19696       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
19697
19698 * particle properties (BAMJET index convention)
19699       CHARACTER*8  ANAME
19700       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19701      &                IICH(210),IIBAR(210),K1(210),K2(210)
19702
19703 * treatment of residual nuclei: 4-momenta
19704       LOGICAL LRCLPR,LRCLTA
19705       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19706      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19707
19708 * treatment of residual nuclei: properties of residual nuclei
19709       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19710      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19711      &                NTOTFI(2),NPROFI(2)
19712
19713 * statistics: residual nuclei
19714       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19715      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19716      &                NINCST(2,4),NINCEV(2),
19717      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19718      &                NRESPB(2),NRESCH(2),NRESEV(4),
19719      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19720      &                NEVAFI(2,2)
19721
19722 * flags for input different options
19723       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19724       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19725      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19726
19727 *      INCLUDE '(DIMPAR)'
19728 *     DIMPAR taken from FLUKA
19729       PARAMETER ( MXXRGN =20000 )
19730       PARAMETER ( MXXMDF =  710 )
19731       PARAMETER ( MXXMDE =  702 )
19732       PARAMETER ( MFSTCK =40000 )
19733       PARAMETER ( MESTCK =  100 )
19734       PARAMETER ( MOSTCK = 2000 )
19735       PARAMETER ( MXPRSN =  100 )
19736       PARAMETER ( MXPDPM =  800 )
19737       PARAMETER ( MXPSCS =30000 )
19738       PARAMETER ( MXGLWN =  300 )
19739       PARAMETER ( MXOUTU =   50 )
19740       PARAMETER ( NALLWP =   64 )
19741       PARAMETER ( NELEMX =   80 )
19742       PARAMETER ( MPDPDX =   18 )
19743       PARAMETER ( MXHTTR =  260 )
19744       PARAMETER ( MXSEAX =   20 )
19745       PARAMETER ( MXHTNC = MXSEAX + 1 )
19746       PARAMETER ( ICOMAX = 2400 )
19747       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
19748       PARAMETER ( NSTBIS =  304 )
19749       PARAMETER ( NQSTIS =   46 )
19750       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
19751       PARAMETER ( MXPABL =  120 )
19752       PARAMETER ( IDMAXP =  450 )
19753       PARAMETER ( IDMXDC = 2000 )
19754       PARAMETER ( MXMCIN =  410 )
19755       PARAMETER ( IHYPMX =    4 )
19756       PARAMETER ( MKBMX1 =   11 )
19757       PARAMETER ( MKBMX2 =   11 )
19758       PARAMETER ( MXIRRD = 2500 )
19759       PARAMETER ( MXTRDC = 1500 )
19760       PARAMETER ( NKTL   =   17 )
19761       PARAMETER ( NBLNMX = 40000000 )
19762
19763 *      INCLUDE '(GENSTK)'
19764 *     GENSTK taken from FLUKA
19765       COMMON / GENSTK /                CXR    (MXPSCS), CYR    (MXPSCS),
19766      &                CZR    (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
19767      &                CZRPOL (MXPSCS), TKI    (MXPSCS), PLR    (MXPSCS),
19768      &                WEI    (MXPSCS), AGESEC (MXPSCS), TV    , TVCMS  ,
19769      &                TVRECL,  TVHEAV, TVBIND,
19770      &                KPART  (MXPSCS), INFEXT (MXPSCS), NP0   , NP
19771
19772 *      INCLUDE '(RESNUC)'
19773 *     RESNUC from FLUKA
19774       LOGICAL LRNFSS, LFRAGM
19775       COMMON /RESNUC/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19776      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19777      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
19778      &                  PYRES,  PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
19779      &                 ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
19780      &                  KTARP,  KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
19781      &                 IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,  ICRES,
19782      &                  IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
19783      &                 IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
19784      &                 IEV4HE, IDEEXG,  IBTAR, ICHTAR, IBLEFT, ICLEFT,
19785      &                 ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
19786      &                 LRNFSS, LFRAGM
19787
19788       PARAMETER ( EMVGEV = 1.0                D-03 )
19789       PARAMETER ( AMUGEV = 0.93149432         D+00 )
19790       PARAMETER ( AMPRTN = 0.93827231         D+00 )
19791       PARAMETER ( AMNTRN = 0.93956563         D+00 )
19792       PARAMETER ( AMELCT = 0.51099906         D-03 )
19793       PARAMETER ( ELCCGS = 4.8032068          D-10 )
19794       PARAMETER ( ELCMKS = 1.60217733         D-19 )
19795       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19796      &                   * 1.D-09 )
19797       PARAMETER ( HLFHLF = 0.5D+00 )
19798       PARAMETER ( FERTHO = 14.33       D-09 )
19799       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
19800       PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
19801       PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
19802
19803 *      INCLUDE '(NUCDAT)'
19804 *     Taken from FLUKA
19805       PARAMETER ( AMUAMU = AMUGEV )
19806       PARAMETER ( AMPROT = AMPRTN )
19807       PARAMETER ( AMNEUT = AMNTRN )
19808       PARAMETER ( AMELEC = AMELCT )
19809       PARAMETER ( R0NUCL = 1.12        D+00 )
19810       PARAMETER ( RCCOUL = 1.7         D+00 )
19811       PARAMETER ( COULPR = COUGFM )
19812       PARAMETER ( AMHYDR = AMPRTN + AMELCT  )
19813       PARAMETER ( AMHTON = AMHYDR - AMNTRN  )
19814       PARAMETER ( AMNTOU = AMNTRN - AMUC12  )
19815       PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
19816       PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
19817 *   Gammin : threshold for deexcitation gammas production, set to 1 keV
19818 *   (this means that up to 1 keV of energy unbalancing can occur
19819 *    during an event)
19820       PARAMETER ( GAMMIN = 1.0D-06 )
19821       PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
19822 *   Tvepsi : "epsilon" for excitation energy, set to gammin / 100
19823       PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
19824 *
19825       COMMON /NUCDAT/ AV0WEL,     APFRMX,     AEFRMX,     AEFRMA,
19826      &                RDSNUC,     V0WELL (2), PFRMMX (2), EFRMMX (2),
19827      &                EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
19828      &                VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
19829      &                PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
19830      &                EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
19831      &                ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV    ,
19832      &                AMRCSQ    , ATO1O3    , ZTO1O3    , FRMRFC    ,
19833      &                ELBNDE (0:110)
19834
19835 *      INCLUDE '(PAREVT)'
19836 *     Taken from FLUKA
19837       PARAMETER ( FRDIFF = 0.2D+00 )
19838       PARAMETER ( ETHSEA = 1.0D+00 )
19839 *
19840       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
19841      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
19842      &        LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
19843      &        LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
19844       COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
19845      &                  LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
19846      &                  LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
19847      &                  LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
19848      &                  LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
19849      &                  LVP2XX, LV2XNW, LNWV2X, LEVFIN
19850
19851 *      INCLUDE '(FHEAVY)'
19852 *     Taken from FLUKA
19853       PARAMETER ( MXHEAV = 100 )
19854       PARAMETER ( KXHEAV =  30 )
19855       CHARACTER*8 ANHEAV
19856       COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19857      &                  CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19858      &                  PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19859      &                  AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
19860      &                  AMHEAV (KXHEAV), AMNHEA (KXHEAV),
19861      &                  KHEAVY (MXHEAV), INFHEA (MXHEAV),
19862      &                  ICHEAV (KXHEAV), IBHEAV (KXHEAV),
19863      &                  IMHEAV (KXHEAV), IHHEAV (KXHEAV),
19864      &                  KHHEAV (IHYPMX,KXHEAV), NPHEAV
19865       COMMON / FHEAVC / ANHEAV (KXHEAV)
19866
19867 * event flag
19868       COMMON /DTEVNO/ NEVENT,ICASCA
19869
19870       DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
19871      &          PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
19872      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
19873
19874       DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
19875       LOGICAL LLCPOT
19876       DATA EXC,NEXC /520*ZERO,520*0/
19877       DATA EXPNUC /4.0D-3,4.0D-3/
19878
19879       IREJ   = 0
19880       LRCLPR = .FALSE.
19881       LRCLTA = .FALSE.
19882
19883 * skip residual nucleus treatment if not requested or in case
19884 * of central collisions
19885       IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
19886
19887       DO 1 K=1,2
19888          IDPAR(K) = 0
19889          IDXPAR(K)= 0
19890          NTOT(K)  = 0
19891          NTOTFI(K)= 0
19892          NPRO(K)  = 0
19893          NPROFI(K)= 0
19894          NN(K)    = 0
19895          NH(K)    = 0
19896          NHPOS(K) = 0
19897          NQ(K)    = 0
19898          EEXC(K)  = ZERO
19899          MO1(K)   = 0
19900          MO2(K)   = 0
19901          DO 2 I=1,4
19902             VRCL(K,I) = ZERO
19903             WRCL(K,I) = ZERO
19904     2    CONTINUE
19905     1 CONTINUE
19906       NFSP = 0
19907       INUC(1) = IP
19908       INUC(2) = IT
19909
19910       DO 3 I=1,NHKK
19911
19912 * number of final state particles
19913          IF (ABS(ISTHKK(I)).EQ.1) THEN
19914             NFSP  = NFSP+1
19915             IDFSP = IDBAM(I)
19916          ENDIF
19917
19918 * properties of remaining nucleon configurations
19919          KF = 0
19920          IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
19921          IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
19922          IF (KF.GT.0) THEN
19923             IF (MO1(KF).EQ.0) MO1(KF) = I
19924             MO2(KF)  = I
19925 *   position of residual nucleus = average position of nucleons
19926             DO 4 K=1,4
19927                VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
19928                WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
19929     4       CONTINUE
19930 *   total number of particles contributing to each residual nucleus
19931             NTOT(KF)  = NTOT(KF)+1
19932             IDTMP     = IDBAM(I)
19933             IDXTMP    = I
19934 *   total charge of residual nuclei
19935             NQ(KF) = NQ(KF)+IICH(IDTMP)
19936 *   number of protons
19937             IF (IDHKK(I).EQ.2212) THEN
19938                NPRO(KF) = NPRO(KF)+1
19939 *   number of neutrons
19940             ELSEIF (IDHKK(I).EQ.2112) THEN
19941                NN(KF) = NN(KF)+1
19942             ELSE
19943 *   number of baryons other than n, p
19944                IF (IIBAR(IDTMP).EQ.1) THEN
19945                   NH(KF) = NH(KF)+1
19946                   IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
19947                ELSE
19948 *   any other mesons (status set to 1)
19949 C                 WRITE(LOUT,1002) KF,IDTMP
19950 C1002             FORMAT(1X,'FICONF:   residual nucleus ',I2,
19951 C    &                   ' containing meson ',I4,', status set to 1')
19952                   ISTHKK(I) = 1
19953                   IDTMP     = IDPAR(KF)
19954                   IDXTMP    = IDXPAR(KF)
19955                   NTOT(KF)  = NTOT(KF)-1
19956                ENDIF
19957             ENDIF
19958             IDPAR(KF)  = IDTMP
19959             IDXPAR(KF) = IDXTMP
19960          ENDIF
19961     3 CONTINUE
19962
19963 * reject elastic events (def: one final state particle = projectile)
19964       IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
19965          IREXCI(3) = IREXCI(3)+1
19966          GOTO 9999
19967 C        RETURN
19968       ENDIF
19969
19970 * check if one nucleus disappeared..
19971 C     IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
19972 C        DO 5 K=1,4
19973 C           PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
19974 C           PRCLPR(K) = ZERO
19975 C   5    CONTINUE
19976 C     ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
19977 C        DO 6 K=1,4
19978 C           PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
19979 C           PRCLTA(K) = ZERO
19980 C   6    CONTINUE
19981 C     ENDIF
19982
19983       ICOR   = 0
19984       INORCL = 0
19985       DO 7 I=1,2
19986          DO 8 K=1,4
19987 * get the average of the nucleon positions
19988             VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
19989             WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
19990             IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
19991             IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
19992     8    CONTINUE
19993 * mass number and charge of residual nuclei
19994          AIF(I)  = DBLE(NTOT(I))
19995          AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
19996          IF (NTOT(I).GT.1) THEN
19997 * masses of residual nuclei in ground state
19998
19999 C           AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I))
20000             AMRCL0(I) = AIF(I)*AMUC12
20001      &                  +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM)
20002
20003 * masses of residual nuclei
20004             PTORCL   = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
20005             AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
20006             IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
20007 *
20008 *   M_res^2 < 0 : configuration not allowed
20009 *
20010 *      a) re-calculate E_exc with scaled nuclear potential
20011 *         (conditional jump to label 9998)
20012 *      b) or reject event if N_loop(max) is exceeded
20013 *         (conditional jump to label 9999)
20014 *
20015             IF (AMRCL(I).LE.ZERO) THEN
20016                IF (IOULEV(3).GT.0)
20017      &            WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
20018      &                             PRCL(I,4),NTOT
20019  1000          FORMAT(1X,'warning! negative excitation energy',/,
20020      &                I4,4E15.4,2I4)
20021                AMRCL(I) = ZERO
20022                EEXC(I)  = ZERO
20023                IF (NLOOP.LE.500) THEN
20024                   GOTO 9998
20025                ELSE
20026                   IREXCI(2) = IREXCI(2)+1
20027                   GOTO 9999
20028                ENDIF
20029 *
20030 *   0 < M_res < M_res0 : mass below ground-state mass
20031 *
20032 *      a) we had residual nuclei with mass N_tot and reasonable E_exc
20033 *         before- assign average E_exc of those configurations to this
20034 *         one ( Nexc(i,N_tot) > 0 )
20035 *      b) or (and this applies always if run in transport codes) go up
20036 *         one mass number and
20037 *           i) if mass now larger than proj/targ mass or if run in
20038 *              transport codes assign average E_exc per wounded nucleon
20039 *              x number of wounded nucleons (Inuc-Ntot)
20040 *          ii) or assign average E_exc of those configurations to this
20041 *              one ( Nexc(i,m) > 0 )
20042 *
20043             ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
20044      &                                                         THEN
20045                M = MIN(NTOT(I),260)
20046                IF (NEXC(I,M).GT.0) THEN
20047                   AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20048                ELSE
20049    70             CONTINUE
20050                   M = M+1
20051 **sr corrected 27.12.06
20052 *                 IF (M.GE.INUC(I)) THEN
20053 *                    AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
20054                   IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
20055                      IF ( INUC (I) .GT. NTOT (I) ) THEN
20056                         AMRCL(I) = AMRCL0(I)
20057      &                         + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
20058                      ELSE
20059                         AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
20060                      END IF
20061 **
20062                   ELSE
20063                      IF (NEXC(I,M).GT.0) THEN
20064                         AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20065                      ELSE
20066                         GOTO 70
20067                      ENDIF
20068                   ENDIF
20069                ENDIF
20070                EEXC(I)  = AMRCL(I)-AMRCL0(I)
20071                ICOR     = ICOR+I
20072 *
20073 *   M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
20074 *
20075 *      a) re-calculate E_exc with scaled nuclear potential
20076 *         (conditional jump to label 9998)
20077 *      b) or reject event if N_loop(max) is exceeded
20078 *         (conditional jump to label 9999)
20079 *
20080 *
20081             ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
20082                IF (IOULEV(3).GT.0)
20083      &            WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
20084  1004          FORMAT(1X,'warning! too high excitation energy',/,
20085      &                I4,1P,2E15.4,3I5)
20086                AMRCL(I) = ZERO
20087                EEXC(I)  = ZERO
20088                IF (NLOOP.LE.500) THEN
20089                   GOTO 9998
20090                ELSE
20091                   IREXCI(2) = IREXCI(2)+1
20092                   GOTO 9999
20093                ENDIF
20094 *
20095 *   Otherwise (reasonable E_exc) :
20096 *      E_exc = M_res - M_res0
20097 *      in addition: calculate and save E_exc per wounded nucleon as
20098 *                   well as E_exc in <E_exc> counter
20099 *
20100             ELSE
20101 * excitation energies of residual nuclei
20102                EEXC(I)   = AMRCL(I)-AMRCL0(I)
20103 **sr 27.12.06 new excitation energy correction by A.F.
20104 *
20105 * all parts with Ilcopt<3 commented since not used
20106 *
20107 * still to be done/decided:
20108 *   Increase Icor and put back both residual nuclei on mass shell
20109 *   with the exciting correction further below.
20110 *   For the moment the modification in the excitation energy is simply
20111 *   corrected by scaling the energy of the residual nucleus.
20112 *
20113                LLCPOT = .TRUE.
20114                ILCOPT = 3
20115                IF ( LLCPOT ) THEN
20116                   NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
20117                   IF ( ILCOPT .LE. 2 ) THEN
20118 C* Patch for Fermi momentum reduction correlated with impact parameter:
20119 C                     FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
20120 C                     DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
20121 C                     AKPRHO = ONE - DLKPRH
20122 C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
20123 C                     FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO  - ONE,
20124 C     &                              0.05D+00 )
20125 C*                    REDORI = 0.75D+00
20126 C*                    REDORI = ONE
20127 C                     REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20128                   ELSE
20129                      DLKPRH = ZERO
20130                      RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
20131 *  Take out roughly one/half of the skin:
20132                      RDCORE = RDCORE - 0.5D+00
20133                      FRCFLL = RDCORE**3
20134                      PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
20135                      PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
20136                      FRCFLL = ONE - PRSKIN
20137                      FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
20138                      REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20139                   END IF
20140                   IF ( NNCHIT .GT. 0 ) THEN
20141 C                     IF ( ILCOPT .EQ. 1 ) THEN
20142 C                        SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
20143 C                        DO 1220 NCH = 1, 10
20144 C                           ETAETA = ( ONE - SKINRH**INUC(I)
20145 C     &                            - DBLE(INUC(I))* ( ONE - FRCFLL )
20146 C     &                            * ( ONE - SKINRH ) )
20147 C     &                            / ( SKINRH**INUC(I) - DBLE (INUC(I))
20148 C     &                            * ( ONE - FRCFLL) * SKINRH )
20149 C                           SKINRH = SKINRH * ( ONE + ETAETA )
20150 C 1220                   CONTINUE
20151 C                        PRSKIN = SKINRH**(NNCHIT-1)
20152 C                     ELSE IF ( ILCOPT .EQ. 2 ) THEN
20153 C                        PRSKIN = ONE - FRCFLL
20154 C                     END IF
20155                      REDCTN = ZERO
20156                      DO 1230 NCH = 1, NNCHIT
20157                         IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
20158                            PRFRMI = (( ONE - 2.D+00 * DLKPRH )
20159      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
20160                         ELSE
20161                            PRFRMI = ( ONE - 2.D+00 * DLKPRH
20162      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
20163                         END IF
20164                         REDCTN = REDCTN + PRFRMI**2
20165  1230                CONTINUE
20166                      REDCTN = REDCTN / DBLE (NNCHIT)
20167                   ELSE
20168                      REDCTN = 0.5D+00
20169                   END IF
20170                   EEXC  (I) = EEXC   (I) * REDCTN / REDORI
20171                   AMRCL (I) = AMRCL0 (I) + EEXC (I)
20172                   PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
20173                END IF
20174 **
20175                IF (ICASCA.EQ.0) THEN
20176                   EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
20177                   M = MIN(NTOT(I),260)
20178                   EXC(I,M)  = EXC(I,M)+EEXC(I)
20179                   NEXC(I,M) = NEXC(I,M)+1
20180                ENDIF
20181             ENDIF
20182          ELSEIF (NTOT(I).EQ.1) THEN
20183             WRITE(LOUT,1003) I
20184  1003       FORMAT(1X,'FICONF:   warning! NTOT(I)=1? (I=',I3,')')
20185             GOTO 9999
20186          ELSE
20187             AMRCL0(I) = ZERO
20188             AMRCL(I)  = ZERO
20189             EEXC(I)   = ZERO
20190             INORCL    = INORCL+I
20191          ENDIF
20192     7 CONTINUE
20193
20194       PRCLPR(5) = AMRCL(1)
20195       PRCLTA(5) = AMRCL(2)
20196
20197       IF (ICOR.GT.0) THEN
20198          IF (INORCL.EQ.0) THEN
20199 * one or both residual nuclei consist of one nucleon only, transform
20200 * this nucleon on mass shell
20201             DO 9 K=1,4
20202                P1IN(K) = PRCL(1,K)
20203                P2IN(K) = PRCL(2,K)
20204     9       CONTINUE
20205             XM1 = AMRCL(1)
20206             XM2 = AMRCL(2)
20207             CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
20208             IF (IREJ1.GT.0) THEN
20209                WRITE(LOUT,*) 'ficonf-mashel rejection'
20210                GOTO 9999
20211             ENDIF
20212             DO 10 K=1,4
20213                PRCL(1,K) = P1OUT(K)
20214                PRCL(2,K) = P2OUT(K)
20215                PRCLPR(K) = P1OUT(K)
20216                PRCLTA(K) = P2OUT(K)
20217    10       CONTINUE
20218             PRCLPR(5) = AMRCL(1)
20219             PRCLTA(5) = AMRCL(2)
20220          ELSE
20221             IF (IOULEV(3).GT.0)
20222      &      WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
20223      &                       INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
20224      &                       AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
20225      &                       AMRCL(2),AMRCL(2)-AMRCL0(2)
20226  1001       FORMAT(1X,'FICONF:   warning! no residual nucleus for',
20227      &             ' correction',/,11X,'at event',I8,
20228      &             ',  nucleon config. 1:',2I4,' 2:',2I4,
20229      &             2(/,11X,3E12.3))
20230             IF (NLOOP.LE.500) THEN
20231                GOTO 9998
20232             ELSE
20233                IREXCI(1) = IREXCI(1)+1
20234             ENDIF
20235          ENDIF
20236       ENDIF
20237
20238 * update counter
20239 C     IF (NRESEV(1).NE.NEVHKK) THEN
20240 C        NRESEV(1) = NEVHKK
20241 C        NRESEV(2) = NRESEV(2)+1
20242 C     ENDIF
20243       NRESEV(2) = NRESEV(2)+1
20244       DO 15 I=1,2
20245          EXCDPM(I)   = EXCDPM(I)+EEXC(I)
20246          EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
20247          NRESTO(I) = NRESTO(I)+NTOT(I)
20248          NRESPR(I) = NRESPR(I)+NPRO(I)
20249          NRESNU(I) = NRESNU(I)+NN(I)
20250          NRESBA(I) = NRESBA(I)+NH(I)
20251          NRESPB(I) = NRESPB(I)+NHPOS(I)
20252          NRESCH(I) = NRESCH(I)+NQ(I)
20253    15 CONTINUE
20254
20255 * evaporation
20256       IF (LEVPRT) THEN
20257          DO 13 I=1,2
20258 * initialize evaporation counter
20259             EEXCFI(I) = ZERO
20260             IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
20261      &          (EEXC(I).GT.ZERO)) THEN
20262 * put residual nuclei into DTEVT1
20263                IDRCL = 80000
20264                JMASS = INT( AIF(I))
20265                JCHAR = INT(AIZF(I))
20266 *  the following patch is required to transmit the correct excitation
20267 *   energy to Eventd
20268                IF (ITRSPT.EQ.1) THEN
20269                   IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
20270      &                (IOULEV(3).GT.0))
20271      &               WRITE(LOUT,*)
20272      &                  ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
20273      &                              AMRCL(I),AMRCL0(I),EEXC(I)
20274                   PRCL0 = PRCL(I,4)
20275                   PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
20276      &                                                    +PRCL(I,3)**2)
20277                   IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
20278                      WRITE(LOUT,*)
20279      &                  ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
20280                   ENDIF
20281                ENDIF
20282                CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
20283      &              PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
20284 **sr 22.6.97
20285                NOBAM(NHKK) = I
20286 **
20287                DO 14 J=1,4
20288                   VHKK(J,NHKK) = VRCL(I,J)
20289                   WHKK(J,NHKK) = WRCL(I,J)
20290    14          CONTINUE
20291 *  interface to evaporation module - fill final residual nucleus into
20292 *  common FKRESN
20293 *   fill resnuc only if code is not used as event generator in Fluka
20294                IF (ITRSPT.NE.1) THEN
20295                   PXRES  = PRCL(I,1)
20296                   PYRES  = PRCL(I,2)
20297                   PZRES  = PRCL(I,3)
20298                   IBRES  = NPRO(I)+NN(I)+NH(I)
20299                   ICRES  = NPRO(I)+NHPOS(I)
20300                   ANOW   = DBLE(IBRES)
20301                   ZNOW   = DBLE(ICRES)
20302                   PTRES  = SQRT(PXRES**2+PYRES**2+PZRES**2)
20303 *   ground state mass of the residual nucleus (should be equal to AM0T)
20304
20305                   AMNRES = AMRCL0(I)
20306                   AMMRES = AMNAMA ( AMNRES, IBRES, ICRES )
20307
20308 *  common FKFINU
20309                   TV = ZERO
20310 *   kinetic energy of residual nucleus
20311                   TVRECL = PRCL(I,4)-AMRCL(I)
20312 *   excitation energy of residual nucleus
20313                   TVCMS  = EEXC(I)
20314                   PTOLD  = PTRES
20315                   PTRES  = SQRT(ABS(TVRECL*(TVRECL+
20316      &                          2.0D0*(AMMRES+TVCMS))))
20317                   IF (PTOLD.LT.ANGLGB) THEN
20318                      CALL DT_RACO(PXRES,PYRES,PZRES)
20319                      PTOLD = ONE
20320                   ENDIF
20321                   PXRES = PXRES*PTRES/PTOLD
20322                   PYRES = PYRES*PTRES/PTOLD
20323                   PZRES = PZRES*PTRES/PTOLD
20324 * zero counter of secondaries from evaporation
20325                   NP = 0
20326 * evaporation
20327                   WE = ONE
20328
20329                   NPHEAV = 0
20330                   LRNFSS = .FALSE.
20331                   LFRAGM = .FALSE.
20332                   CALL EVEVAP(WE)
20333
20334 * put evaporated particles and residual nuclei to DTEVT1
20335                   MO = NHKK
20336                   CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
20337                ENDIF
20338                EEXCFI(I) = EXCITF
20339                EXCEVA(I) = EXCEVA(I)+EXCITF
20340             ENDIF
20341    13    CONTINUE
20342       ENDIF
20343
20344       RETURN
20345
20346 C9998 IREXCI(1) = IREXCI(1)+1
20347  9998 IREJ   = IREJ+1
20348  9999 CONTINUE
20349       LRCLPR = .TRUE.
20350       LRCLTA = .TRUE.
20351       IREJ   = IREJ+1
20352       RETURN
20353       END
20354
20355 *$ CREATE DT_EVA2HE.FOR
20356 *COPY DT_EVA2HE
20357 *                                                                      *
20358 *====eva2he============================================================*
20359 *                                                                      *
20360       SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
20361
20362 ************************************************************************
20363 * Interface between common's of evaporation module (FKFINU,FKFHVY)     *
20364 * and DTEVT1.                                                          *
20365 *    MO    DTEVT1-index of "mother" (residual) nucleus before evap.    *
20366 *    EEXCF exitation energy of residual nucleus after evaporation      *
20367 *    IRCL  = 1 projectile residual nucleus                             *
20368 *          = 2 target     residual nucleus                             *
20369 * This version dated 19.04.95 is written by S. Roesler.                *
20370 *                                                                      *
20371 * Last change 27.12.2006 by S. Roesler.                                *
20372 ************************************************************************
20373
20374       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20375       SAVE
20376
20377       PARAMETER ( LINP = 10 ,
20378      &            LOUT = 6 ,
20379      &            LDAT = 9 )
20380
20381       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
20382
20383 * event history
20384
20385       PARAMETER (NMXHKK=200000)
20386
20387       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
20388      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
20389      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
20390 * Note: DTEVT2 - special use for heavy fragments !
20391 *       (IDRES(I) = mass number, IDXRES(I) = charge)
20392
20393 * extended event history
20394       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
20395      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
20396      &                IHIST(2,NMXHKK)
20397
20398 * particle properties (BAMJET index convention)
20399       CHARACTER*8  ANAME
20400       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20401      &                IICH(210),IIBAR(210),K1(210),K2(210)
20402
20403 * flags for input different options
20404       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20405       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20406      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20407
20408 * statistics: residual nuclei
20409       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
20410      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
20411      &                NINCST(2,4),NINCEV(2),
20412      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
20413      &                NRESPB(2),NRESCH(2),NRESEV(4),
20414      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
20415      &                NEVAFI(2,2)
20416
20417 * treatment of residual nuclei: properties of residual nuclei
20418       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
20419      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
20420      &                NTOTFI(2),NPROFI(2)
20421
20422 *      INCLUDE '(DIMPAR)'
20423 *     Taken from FLUKA
20424       PARAMETER ( MXXRGN =20000 )
20425       PARAMETER ( MXXMDF =  710 )
20426       PARAMETER ( MXXMDE =  702 )
20427       PARAMETER ( MFSTCK =40000 )
20428       PARAMETER ( MESTCK =  100 )
20429       PARAMETER ( MOSTCK = 2000 )
20430       PARAMETER ( MXPRSN =  100 )
20431       PARAMETER ( MXPDPM =  800 )
20432       PARAMETER ( MXPSCS =30000 )
20433       PARAMETER ( MXGLWN =  300 )
20434       PARAMETER ( MXOUTU =   50 )
20435       PARAMETER ( NALLWP =   64 )
20436       PARAMETER ( NELEMX =   80 )
20437       PARAMETER ( MPDPDX =   18 )
20438       PARAMETER ( MXHTTR =  260 )
20439       PARAMETER ( MXSEAX =   20 )
20440       PARAMETER ( MXHTNC = MXSEAX + 1 )
20441       PARAMETER ( ICOMAX = 2400 )
20442       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
20443       PARAMETER ( NSTBIS =  304 )
20444       PARAMETER ( NQSTIS =   46 )
20445       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
20446       PARAMETER ( MXPABL =  120 )
20447       PARAMETER ( IDMAXP =  450 )
20448       PARAMETER ( IDMXDC = 2000 )
20449       PARAMETER ( MXMCIN =  410 )
20450       PARAMETER ( IHYPMX =    4 )
20451       PARAMETER ( MKBMX1 =   11 )
20452       PARAMETER ( MKBMX2 =   11 )
20453       PARAMETER ( MXIRRD = 2500 )
20454       PARAMETER ( MXTRDC = 1500 )
20455       PARAMETER ( NKTL   =   17 )
20456       PARAMETER ( NBLNMX = 40000000 )
20457
20458 *      INCLUDE '(GENSTK)'
20459 *     Taken from FLUKA
20460       PARAMETER ( MXP = MXPSCS )
20461 *
20462       COMMON / GENSTK /                CXR    (MXPSCS), CYR    (MXPSCS),
20463      &                CZR    (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
20464      &                CZRPOL (MXPSCS), TKI    (MXPSCS), PLR    (MXPSCS),
20465      &                WEI    (MXPSCS), AGESEC (MXPSCS), TV    , TVCMS  ,
20466      &                TVRECL,  TVHEAV, TVBIND,
20467      &                KPART  (MXPSCS), INFEXT (MXPSCS), NP0   , NP
20468
20469 *      INCLUDE '(RESNUC)'
20470       LOGICAL LRNFSS, LFRAGM
20471       COMMON /RESNUC/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
20472      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
20473      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
20474      &                  PYRES,  PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
20475      &                 ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
20476      &                  KTARP,  KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
20477      &                 IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,  ICRES,
20478      &                  IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
20479      &                 IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
20480      &                 IEV4HE, IDEEXG,  IBTAR, ICHTAR, IBLEFT, ICLEFT,
20481      &                 ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
20482      &                 LRNFSS, LFRAGM
20483 *     Taken from FLUKA
20484
20485 *      INCLUDE '(FHEAVY)'
20486 *     Taken from FLUKA
20487       PARAMETER ( MXHEAV = 100 )
20488       PARAMETER ( KXHEAV =  30 )
20489       CHARACTER*8 ANHEAV
20490       COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20491      &                  CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20492      &                  PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20493      &                  AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
20494      &                  AMHEAV (KXHEAV), AMNHEA (KXHEAV),
20495      &                  KHEAVY (MXHEAV), INFHEA (MXHEAV),
20496      &                  ICHEAV (KXHEAV), IBHEAV (KXHEAV),
20497      &                  IMHEAV (KXHEAV), IHHEAV (KXHEAV),
20498      &                  KHHEAV (IHYPMX,KXHEAV), NPHEAV
20499       COMMON / FHEAVC / ANHEAV (KXHEAV)
20500
20501       DIMENSION IPTOKP(39)
20502       DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
20503      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
20504      & 100, 101, 97, 102, 98, 103, 109, 115 /
20505
20506       IREJ = 0
20507
20508 * skip if evaporation package is not included
20509       IF (.NOT.LEVAPO) RETURN
20510
20511 * update counter
20512       IF (NRESEV(3).NE.NEVHKK) THEN
20513          NRESEV(3) = NEVHKK
20514          NRESEV(4) = NRESEV(4)+1
20515       ENDIF
20516
20517       IF (LEMCCK)
20518      &   CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
20519      &                                                   IDUM,IDUM)
20520 * mass number/charge of residual nucleus before evaporation
20521       IBTOT = IDRES(MO)
20522       IZTOT = IDXRES(MO)
20523
20524 * protons/neutrons/gammas
20525       DO 1 I=1,NP
20526          PX    = CXR(I)*PLR(I)
20527          PY    = CYR(I)*PLR(I)
20528          PZ    = CZR(I)*PLR(I)
20529          ID    = IPTOKP(KPART(I))
20530          IDPDG = IDT_IPDGHA(ID)
20531          AM    = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
20532      &           (2.0D0*MAX(TKI(I),TINY10))
20533          IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
20534             WRITE(LOUT,1000) ID,AM,AAM(ID)
20535  1000       FORMAT(1X,'EVA2HE:  inconsistent mass of evap. ',
20536      &             'particle',I3,2E10.3)
20537          ENDIF
20538          PE = TKI(I)+AM
20539          CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
20540          NOBAM(NHKK) = IRCL
20541          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20542          IBTOT = IBTOT-IIBAR(ID)
20543          IZTOT = IZTOT-IICH(ID)
20544     1 CONTINUE
20545
20546 * heavy fragments
20547       DO 2 I=1,NPHEAV
20548          PX     = CXHEAV(I)*PHEAVY(I)
20549          PY     = CYHEAV(I)*PHEAVY(I)
20550          PZ     = CZHEAV(I)*PHEAVY(I)
20551          IDHEAV = 80000
20552          AM     = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
20553      &            (2.0D0*MAX(TKHEAV(I),TINY10))
20554          PE     = TKHEAV(I)+AM
20555          CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
20556      &                  IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
20557          NOBAM(NHKK) = IRCL
20558          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20559          IBTOT = IBTOT-IBHEAV(KHEAVY(I))
20560          IZTOT = IZTOT-ICHEAV(KHEAVY(I))
20561     2 CONTINUE
20562
20563       IF (IBRES.GT.0) THEN
20564 * residual nucleus after evaporation
20565          IDNUC = 80000
20566          CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
20567      &                                        IBRES,ICRES,0)
20568          NOBAM(NHKK) = IRCL
20569       ENDIF
20570       EEXCF = TVCMS
20571       NTOTFI(IRCL) = IBRES
20572       NPROFI(IRCL) = ICRES
20573       IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
20574       IBTOT = IBTOT-IBRES
20575       IZTOT = IZTOT-ICRES
20576
20577 * count events with fission
20578       NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
20579       IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
20580
20581 * energy-momentum conservation check
20582       IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
20583 C     IF (IREJ.GT.0) THEN
20584 C        CALL DT_EVTOUT(4)
20585 C        WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
20586 C     ENDIF
20587 * baryon-number/charge conservation check
20588       IF (IBTOT+IZTOT.NE.0) THEN
20589          WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
20590  1001    FORMAT(1X,'EVA2HE:   baryon-number/charge conservation ',
20591      &          'failure at event ',I8,' :  IBTOT,IZTOT = ',2I3)
20592       ENDIF
20593
20594       RETURN
20595       END
20596
20597 *$ CREATE DT_EBIND.FOR
20598 *COPY DT_EBIND
20599 *
20600 *===ebind==============================================================*
20601 *
20602       DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
20603
20604 ************************************************************************
20605 * Binding energy for nuclei.                                           *
20606 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972)                  *
20607 *                 IA        mass number                                *
20608 *                 IZ        atomic number                              *
20609 * This version dated 5.5.95   is updated by S. Roesler.                *
20610 ************************************************************************
20611
20612       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20613       SAVE
20614
20615       PARAMETER ( LINP = 10 ,
20616      &            LOUT = 6 ,
20617      &            LDAT = 9 )
20618
20619       PARAMETER (ZERO=0.0D0)
20620
20621       DATA       A1,       A2,        A3,        A4,      A5
20622      &     / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
20623
20624       IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
20625          WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0.  ',IA,IZ
20626          DT_EBIND = ZERO
20627          RETURN
20628       ENDIF
20629       AA = IA
20630       DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
20631      &        -A4*(IA-2*IZ)**2/AA
20632       IF (MOD(IA,2).EQ.1) THEN
20633          IA5 = 0
20634       ELSEIF (MOD(IZ,2).EQ.1) THEN
20635          IA5 = 1
20636       ELSE
20637          IA5 = -1
20638       ENDIF
20639       DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
20640
20641       RETURN
20642       END
20643
20644 ************************************************************************
20645 *                                                                      *
20646 *  DPMJET 3.0:   cross section routines                                *
20647 *                                                                      *
20648 ************************************************************************
20649 *
20650 *
20651 *     SUBROUTINE DT_SHNDIF
20652 *         diffractive cross sections (all energies)
20653 *     SUBROUTINE DT_PHOXS
20654 *         total and inel. cross sections from PHOJET interpol. tables
20655 *     SUBROUTINE DT_XSHN
20656 *         total and el. cross sections for all energies
20657 *     SUBROUTINE DT_SIHNAB
20658 *         pion 2-nucleon absorption cross sections
20659 *     SUBROUTINE DT_SIGEMU
20660 *         cross section for target "compounds"
20661 *     SUBROUTINE DT_SIGGA
20662 *         photon nucleus cross sections
20663 *     SUBROUTINE DT_SIGGAT
20664 *         photon nucleus cross sections from tables
20665 *     SUBROUTINE DT_SANO
20666 *         anomalous hard photon-nucleon cross sections from tables
20667 *     SUBROUTINE DT_SIGGP
20668 *         photon nucleon cross sections
20669 *     SUBROUTINE DT_SIGVEL
20670 *         quasi-elastic vector meson prod. cross sections
20671 *     DOUBLE PRECISION FUNCTION DT_SIGVP
20672 *         sigma_VN(tilde)
20673 *     DOUBLE PRECISION FUNCTION DT_RRM2
20674 *     DOUBLE PRECISION FUNCTION DT_RM2
20675 *     DOUBLE PRECISION FUNCTION DT_SAM2
20676 *     SUBROUTINE DT_CKMT
20677 *     SUBROUTINE DT_CKMTX
20678 *     SUBROUTINE DT_PDF0
20679 *     SUBROUTINE DT_CKMTQ0
20680 *     SUBROUTINE DT_CKMTDE
20681 *     SUBROUTINE DT_CKMTPR
20682 *     FUNCTION DT_CKMTFF
20683 *
20684 *     SUBROUTINE DT_FLUINI
20685 *         total nucleon cross section fluctuation treatment
20686 *
20687 *     SUBROUTINE DT_SIGTBL
20688 *         pre-tabulation of low-energy elastic x-sec. using SIHNEL
20689 *     SUBROUTINE DT_XSTABL
20690 *         service routines
20691 *
20692 *
20693 *$ CREATE DT_SHNDIF.FOR
20694 *COPY DT_SHNDIF
20695 *
20696 *===shndif===============================================================*
20697 *
20698       SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
20699
20700 **********************************************************************
20701 *   Single diffractive hadron-nucleon cross sections                 *
20702 *                                              S.Roesler 14/1/93     *
20703 *                                                                    *
20704 *   The cross sections are calculated from extrapolated single       *
20705 *   diffractive antiproton-proton cross sections (DTUJET92) using    *
20706 *   scaling relations between total and single diffractive cross     *
20707 *   sections.                                                        *
20708 **********************************************************************
20709
20710       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20711       SAVE
20712       PARAMETER (ZERO=0.0D0)
20713
20714 * particle properties (BAMJET index convention)
20715       CHARACTER*8  ANAME
20716       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20717      &                IICH(210),IIBAR(210),K1(210),K2(210)
20718 *
20719       CSD1   =   4.201483727D0
20720       CSD4   = -0.4763103556D-02
20721       CSD5   =  0.4324148297D0
20722 *
20723       CHMSD1 =  0.8519297242D0
20724       CHMSD4 = -0.1443076599D-01
20725       CHMSD5 =  0.4014954567D0
20726 *
20727       EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
20728       PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
20729 *
20730       SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20731       SHMSD  = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
20732       FRAC   = SHMSD/SDIAPP
20733 *
20734       GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
20735      &     999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
20736      &      10, 10, 20, 20, 20) KPROJ
20737 *
20738    10 CONTINUE
20739 *---------------------------- p - p , n - p , sigma0+- - p ,
20740 *                             Lambda - p
20741       CSD1   =  6.004476070D0
20742       CSD4   = -0.1257784606D-03
20743       CSD5   =  0.2447335720D0
20744       SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20745       SIGDIH = FRAC*SIGDIF
20746       RETURN
20747 *
20748    20 CONTINUE
20749 *
20750       KPSCAL = 2
20751       KTSCAL = 1
20752 C     F      = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
20753       DUMZER = ZERO
20754       CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
20755       F      = SDIAPP/SIGTO
20756       KT     = 1
20757 C     SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
20758       CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
20759       SIGDIF = SIGTO*F
20760       SIGDIH = FRAC*SIGDIF
20761       RETURN
20762 *
20763   999 CONTINUE
20764 *-------------------------- leptons..
20765       SIGDIF = 1.D-10
20766       SIGDIH = 1.D-10
20767       RETURN
20768       END
20769
20770 *$ CREATE DT_PHOXS.FOR
20771 *COPY DT_PHOXS
20772 *
20773 *===phoxs================================================================*
20774 *
20775       SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
20776
20777 ************************************************************************
20778 * Total/inelastic proton-nucleon cross sections taken from PHOJET-     *
20779 * interpolation tables.                                                *
20780 * This version dated 05.11.97 is written by S. Roesler                 *
20781 ************************************************************************
20782
20783       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20784       SAVE
20785
20786       PARAMETER ( LINP = 10 ,
20787      &            LOUT = 6 ,
20788      &            LDAT = 9 )
20789
20790       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20791       PARAMETER (TWOPI  = 6.283185307179586454D+00,
20792      &           PI     = TWOPI/TWO,
20793      &           GEV2MB = 0.38938D0)
20794
20795       LOGICAL LFIRST
20796       DATA LFIRST /.TRUE./
20797
20798 * nucleon-nucleon event-generator
20799       CHARACTER*8 CMODEL
20800       LOGICAL LPHOIN
20801       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20802
20803 * particle properties (BAMJET index convention)
20804       CHARACTER*8  ANAME
20805       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20806      &                IICH(210),IIBAR(210),K1(210),K2(210)
20807
20808 **PHOJET105a
20809 C     PARAMETER (IEETAB=10)
20810 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20811 **PHOJET110
20812
20813 C  energy-interpolation table
20814       INTEGER IEETA2
20815       PARAMETER ( IEETA2 = 20 )
20816       INTEGER ISIMAX
20817       DOUBLE PRECISION SIGTAB,SIGECM
20818       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20819 **
20820
20821       IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
20822          WRITE(LOUT,*) MCGENE
20823  1000    FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
20824          STOP
20825       ENDIF
20826
20827       IF (ECM.LE.ZERO) THEN
20828          EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
20829          ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
20830       ENDIF
20831
20832       IF (MODE.EQ.1) THEN
20833 * DL
20834          DELDL = 0.0808D0
20835          EPSDL = -0.4525D0
20836          S     = ECM*ECM
20837          STOT  = 21.7D0*S**DELDL+56.08D0*S**EPSDL
20838          ALPHAP= 0.25D0
20839          BEL   = 8.5D0+2.D0*ALPHAP*LOG(S)
20840          SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
20841          SINE  = STOT-SIGEL
20842          SDIF1 = ZERO
20843       ELSE
20844 * Phojet
20845          IP = 1
20846          IF(ECM.LE.SIGECM(IP,1)) THEN
20847            I1 = 1
20848            I2 = 1
20849          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
20850            DO 1 I=2,ISIMAX
20851               IF (ECM.LE.SIGECM(IP,I)) GOTO 2
20852     1      CONTINUE
20853     2      CONTINUE
20854            I1 = I-1
20855            I2 = I
20856          ELSE
20857            IF (LFIRST) THEN
20858               WRITE(LOUT,'(/1X,A,2E12.3)')
20859      &          'PHOXS: warning! energy above initialization limit (',
20860      &          ECM,SIGECM(IP,ISIMAX)
20861              LFIRST = .FALSE.
20862            ENDIF
20863            I1 = ISIMAX
20864            I2 = ISIMAX
20865          ENDIF
20866          FAC2 = ZERO
20867          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
20868      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
20869          FAC1  = ONE-FAC2
20870          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
20871          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
20872          SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
20873      &           FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
20874          BEL   = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
20875       ENDIF
20876
20877       RETURN
20878       END
20879
20880 *$ CREATE DT_XSHN.FOR
20881 *COPY DT_XSHN
20882 *
20883 *===xshn===============================================================*
20884 *
20885       SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
20886
20887 ************************************************************************
20888 * Total and elastic hadron-nucleon cross section.                      *
20889 * Below 500GeV cross sections are based on the '98 data compilation    *
20890 * of the PDG. At higher energies PHOJET results are used (patched to   *
20891 * the low energy data at 500GeV).                                      *
20892 *     IP      projectile index (BAMJET numbering scheme)               *
20893 *             (should be in the range 1..25)                           *
20894 *     IT      target index (BAMJET numbering scheme)                   *
20895 *             (1 = proton, 8 = neutron)                                *
20896 *     PL      laboratory momentum                                      *
20897 *     ECM     cm. energy (ignored if PL>0)                             *
20898 *     STOT    total cross section                                      *
20899 *     SELA    elastic cross section                                    *
20900 * Last change: 24.4.99 by S. Roesler                                   *
20901 ************************************************************************
20902
20903       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20904       SAVE
20905
20906       PARAMETER ( LINP = 10 ,
20907      &            LOUT = 6 ,
20908      &            LDAT = 9 )
20909
20910       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
20911
20912       PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
20913      &           PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
20914       PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
20915
20916       LOGICAL LFIRST
20917
20918 * particle properties (BAMJET index convention)
20919       CHARACTER*8  ANAME
20920       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20921      &                IICH(210),IIBAR(210),K1(210),K2(210)
20922
20923 * nucleon-nucleon event-generator
20924       CHARACTER*8 CMODEL
20925       LOGICAL LPHOIN
20926       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20927 **PHOJET105a
20928 C     PARAMETER (IEETAB=10)
20929 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20930 **PHOJET110
20931
20932 C  energy-interpolation table
20933       INTEGER IEETA2
20934       PARAMETER ( IEETA2 = 20 )
20935       INTEGER ISIMAX
20936       DOUBLE PRECISION SIGTAB,SIGECM
20937       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20938
20939       DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
20940       DIMENSION IDXDAT(25,2)
20941 *
20942       DATA APL /
20943      &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
20944      &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
20945      &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
20946      &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
20947      & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
20948      & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
20949      & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
20950 *
20951 * total cross sections:
20952 * p p
20953       DATA (ASIGTO(1,K),K=1,NPOINT) /
20954      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
20955      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
20956      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
20957      & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
20958      & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
20959      & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
20960      & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
20961 * pbar p
20962       DATA (ASIGTO(2,K),K=1,NPOINT) /
20963      & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
20964      & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
20965      & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
20966      & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
20967      & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
20968      & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
20969      & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
20970 * n p
20971       DATA (ASIGTO(3,K),K=1,NPOINT) /
20972      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
20973      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
20974      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
20975      & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
20976      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
20977      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
20978      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
20979 * pi+ p
20980       DATA (ASIGTO(4,K),K=1,NPOINT) /
20981      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
20982      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
20983      & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
20984      & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
20985      & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
20986      & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
20987      & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
20988 * pi- p
20989       DATA (ASIGTO(5,K),K=1,NPOINT) /
20990      & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
20991      & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
20992      & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
20993      & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
20994      & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
20995      & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
20996      & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
20997 * K+ p
20998       DATA (ASIGTO(6,K),K=1,NPOINT) /
20999      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21000      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
21001      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
21002      & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
21003      & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21004      & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21005      & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21006 * K- p
21007       DATA (ASIGTO(7,K),K=1,NPOINT) /
21008      & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21009      & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21010      & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21011      & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21012      & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21013      & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21014      & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21015 * K+ n
21016       DATA (ASIGTO(8,K),K=1,NPOINT) /
21017      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21018      & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21019      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21020      & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21021      & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21022      & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21023      & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21024 * K- n
21025       DATA (ASIGTO(9,K),K=1,NPOINT) /
21026      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21027      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21028      & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21029      & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21030      & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21031      & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21032      & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21033 * Lambda p
21034       DATA (ASIGTO(10,K),K=1,NPOINT) /
21035      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21036      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21037      & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21038      & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21039      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21040      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21041      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21042 *
21043 * elastic cross sections:
21044 * p p
21045       DATA (ASIGEL(1,K),K=1,NPOINT) /
21046      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21047      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21048      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21049      & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21050      & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21051      & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21052      & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21053 * pbar p
21054       DATA (ASIGEL(2,K),K=1,NPOINT) /
21055      & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21056      & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21057      & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21058      & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21059      & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21060      & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21061      & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21062 * n p
21063       DATA (ASIGEL(3,K),K=1,NPOINT) /
21064      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21065      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21066      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21067      & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21068      & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21069      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21070      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21071 * pi+ p
21072       DATA (ASIGEL(4,K),K=1,NPOINT) /
21073      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21074      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21075      & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21076      & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21077      & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21078      & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21079      & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21080 * pi- p
21081       DATA (ASIGEL(5,K),K=1,NPOINT) /
21082      & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21083      & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21084      & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21085      & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21086      & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21087      & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21088      & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21089 * K+ p
21090       DATA (ASIGEL(6,K),K=1,NPOINT) /
21091      & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21092      & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21093      & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21094      & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21095      & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21096      & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21097      & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21098 * K- p
21099       DATA (ASIGEL(7,K),K=1,NPOINT) /
21100      & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21101      & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21102      & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21103      & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21104      & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21105      & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21106      & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21107 * K+ n
21108       DATA (ASIGEL(8,K),K=1,NPOINT) /
21109      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21110      & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21111      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21112      & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21113      & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21114      & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21115      & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21116 * K- n
21117       DATA (ASIGEL(9,K),K=1,NPOINT) /
21118      & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21119      & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21120      & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21121      & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21122      & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21123      & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21124      & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21125 * Lambda p
21126       DATA (ASIGEL(10,K),K=1,NPOINT) /
21127      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21128      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21129      & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21130      & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21131      & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21132      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21133      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21134
21135       DATA (IDXDAT(K,1),K=1,25) /
21136      &  1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21137      &  1, 3,45, 8, 9/
21138       DATA (IDXDAT(K,2),K=1,25) /
21139      &  3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21140      &  3, 1,45, 6, 7/
21141
21142       DATA LFIRST /.TRUE./
21143
21144       IF (LFIRST) THEN
21145          APLABL = LOG10(PLABLO)
21146          APLABH = LOG10(PLABHI)
21147          APTHRE = LOG10(PTHRE)
21148          ADP1   = (APTHRE-APLABL)/DBLE(NPOIN1)
21149          ADP2   = (APLABH-APTHRE)/DBLE(NPOIN2)
21150          DUM0   = ZERO
21151          PHOPLA = PLABHI
21152          PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21153          ECMS   = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21154          IF (MCGENE.EQ.2) THEN
21155             IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21156                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21157             ELSE
21158                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21159             ENDIF
21160          ELSE
21161             CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21162          ENDIF
21163          PHOSEL = PHOSTO-PHOSIN
21164          APHOST = LOG10(PHOSTO)
21165          APHOSE = LOG10(PHOSEL)
21166          LFIRST = .FALSE.
21167       ENDIF
21168       STOT = ZERO
21169       SELA = ZERO
21170       PLAB = PL
21171       ECMS = ECM
21172       IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21173          WRITE(LOUT,1000) IP,IT
21174  1000    FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21175      &          'proj/target',2I4)
21176          STOP
21177       ENDIF
21178
21179       IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21180          ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21181          PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21182       ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21183          WRITE(LOUT,1001) PLAB,ECMS
21184  1001    FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21185          STOP
21186       ENDIF
21187
21188 * index of spectrum
21189       IDXP = IP
21190       IF (IP.GT.25) THEN
21191          IF (AAM(IP).GT.ZERO) THEN
21192             IF (ABS(IIBAR(IP)).GT.0) THEN
21193                IDXP = 1
21194             ELSE
21195                IDXP = 13
21196             ENDIF
21197          ELSE
21198             IDXP = 7
21199          ENDIF
21200       ENDIF
21201       IDXT = 1
21202       IF (IT.EQ.8) IDXT = 2
21203       IDXS = IDXDAT(IDXP,IDXT)
21204       IF (IDXS.EQ.0) RETURN
21205
21206 * compute momentum bin indices
21207       IF (PLAB.LT.PLABLO) THEN
21208          IDX0 = 1
21209          IDX1 = 1
21210       ELSEIF (PLAB.GE.PLABHI) THEN
21211          IDX0 = NPOINT
21212          IDX1 = NPOINT
21213       ELSE
21214          APLAB = LOG10(PLAB)
21215          IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21216             IDX0 = INT((APLAB-APLABL)/ADP1)+1
21217          ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21218             IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21219          ENDIF
21220          IDX1 = IDX0+1
21221       ENDIF
21222
21223 * interpolate cross section
21224       IF (IDXS.GT.10) THEN
21225          IDXS1 = IDXS/10
21226          IDXS2 = IDXS-10*IDXS1
21227          IF (IDX0.EQ.IDX1) THEN
21228             IF (IDX0.EQ.1) THEN
21229                ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21230                ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21231             ELSE
21232                DUM0   = ZERO
21233                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21234                PHOSEL = PHOSTO-PHOSIN
21235                ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21236                ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21237                ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21238                ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21239                ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21240                ASELA  = 0.5D0*(ASELA1+ASELA2)
21241             ENDIF
21242          ELSE
21243             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21244             ASTOT1 = ASIGTO(IDXS1,IDX0)+
21245      &               FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21246             ASTOT2 = ASIGTO(IDXS2,IDX0)+
21247      &               FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21248             ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21249             ASELA1 = ASIGEL(IDXS1,IDX0)+
21250      &               FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21251             ASELA2 = ASIGEL(IDXS2,IDX0)+
21252      &               FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21253             ASELA  = 0.5D0*(ASELA1+ASELA2)
21254          ENDIF
21255       ELSE
21256          IF (IDX0.EQ.IDX1) THEN
21257             IF (IDX0.EQ.1) THEN
21258                ASTOT = ASIGTO(IDXS,IDX0)
21259                ASELA = ASIGEL(IDXS,IDX0)
21260             ELSE
21261                DUM0   = ZERO
21262                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21263                PHOSEL = PHOSTO-PHOSIN
21264                ASTOT  = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21265                ASELA  = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21266             ENDIF
21267          ELSE
21268             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21269             ASTOT = ASIGTO(IDXS,IDX0)+
21270      &              FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21271             ASELA = ASIGEL(IDXS,IDX0)+
21272      &              FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21273          ENDIF
21274       ENDIF
21275       STOT = 10.0D0**ASTOT
21276       SELA = 10.0D0**ASELA
21277
21278       RETURN
21279       END
21280
21281 *$ CREATE DT_SIHNAB.FOR
21282 *COPY DT_SIHNAB
21283 *
21284 *===sihnab===============================================================*
21285 *
21286       SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21287
21288 **********************************************************************
21289 * Pion 2-nucleon absorption cross sections.                          *
21290 * (sigma_tot for pi+ d --> p p, pi- d --> n n                        *
21291 *  taken from Ritchie PRC 28 (1983) 926 )                            *
21292 * This version dated 18.05.96 is written by S. Roesler               *
21293 **********************************************************************
21294
21295       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21296       SAVE
21297       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21298       PARAMETER (AMPR = 938.0D0,
21299      &           AMPI = 140.0D0,
21300      &           AMDE = TWO*AMPR,
21301      &           A    = -1.2D0,
21302      &           B    = 3.5D0,
21303      &           C    = 7.4D0,
21304      &           D    = 5600.0D0,
21305      &           ER   = 2136.0D0)
21306
21307       SIGABS = ZERO
21308       IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21309      &                   .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21310       PTOT = PLAB*1.0D3
21311       EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21312       IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21313       ECM  = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21314       SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21315 * approximate 3N-abs., I=1-abs. etc.
21316       SIGABS = SIGABS/0.40D0
21317 * pi0-absorption (rough approximation!!)
21318       IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21319
21320       RETURN
21321       END
21322
21323 *$ CREATE DT_SIGEMU.FOR
21324 *COPY DT_SIGEMU
21325 *
21326 *===sigemu=============================================================*
21327 *
21328       SUBROUTINE DT_SIGEMU
21329
21330 ************************************************************************
21331 * Combined cross section for target compounds.                         *
21332 * This version dated 6.4.98   is written by S. Roesler                 *
21333 ************************************************************************
21334
21335       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21336       SAVE
21337
21338       PARAMETER ( LINP = 10 ,
21339      &            LOUT = 6 ,
21340      &            LDAT = 9 )
21341
21342       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21343      &           OHALF=0.5D0,ONE=1.0D0)
21344
21345       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21346
21347 * Glauber formalism: cross sections
21348       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21349      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21350      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21351      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21352      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21353      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21354      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21355      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21356      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21357      &                BSLOPE,NEBINI,NQBINI
21358
21359 * emulsion treatment
21360       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21361      &                NCOMPO,IEMUL
21362
21363 * nucleon-nucleon event-generator
21364       CHARACTER*8 CMODEL
21365       LOGICAL LPHOIN
21366       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21367
21368       IF (MCGENE.NE.4) THEN
21369          WRITE(LOUT,'(A)') ' DT_SIGEMU:    Combined cross sections'
21370          WRITE(LOUT,'(15X,A)') '-----------------------'
21371       ENDIF
21372       DO 1 IE=1,NEBINI
21373          DO 2 IQ=1,NQBINI
21374             SIGTOT = ZERO
21375             SIGELA = ZERO
21376             SIGQEP = ZERO
21377             SIGQET = ZERO
21378             SIGQE2 = ZERO
21379             SIGPRO = ZERO
21380             SIGDEL = ZERO
21381             SIGDQE = ZERO
21382             ERRTOT = ZERO
21383             ERRELA = ZERO
21384             ERRQEP = ZERO
21385             ERRQET = ZERO
21386             ERRQE2 = ZERO
21387             ERRPRO = ZERO
21388             ERRDEL = ZERO
21389             ERRDQE = ZERO
21390             IF (NCOMPO.GT.0) THEN
21391                DO 3 IC=1,NCOMPO
21392                   SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21393                   SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21394                   SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21395                   SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21396                   SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21397                   SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21398                   SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21399                   SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21400                   ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21401                   ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21402                   ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21403                   ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21404                   ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21405                   ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21406                   ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21407                   ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21408     3          CONTINUE
21409                ERRTOT = SQRT(ERRTOT)
21410                ERRELA = SQRT(ERRELA)
21411                ERRQEP = SQRT(ERRQEP)
21412                ERRQET = SQRT(ERRQET)
21413                ERRQE2 = SQRT(ERRQE2)
21414                ERRPRO = SQRT(ERRPRO)
21415                ERRDEL = SQRT(ERRDEL)
21416                ERRDQE = SQRT(ERRDQE)
21417             ELSE
21418                SIGTOT = XSTOT(IE,IQ,1)
21419                SIGELA = XSELA(IE,IQ,1)
21420                SIGQEP = XSQEP(IE,IQ,1)
21421                SIGQET = XSQET(IE,IQ,1)
21422                SIGQE2 = XSQE2(IE,IQ,1)
21423                SIGPRO = XSPRO(IE,IQ,1)
21424                SIGDEL = XSDEL(IE,IQ,1)
21425                SIGDQE = XSDQE(IE,IQ,1)
21426                ERRTOT = XETOT(IE,IQ,1)
21427                ERRELA = XEELA(IE,IQ,1)
21428                ERRQEP = XEQEP(IE,IQ,1)
21429                ERRQET = XEQET(IE,IQ,1)
21430                ERRQE2 = XEQE2(IE,IQ,1)
21431                ERRPRO = XEPRO(IE,IQ,1)
21432                ERRDEL = XEDEL(IE,IQ,1)
21433                ERRDQE = XEDQE(IE,IQ,1)
21434             ENDIF
21435             IF (MCGENE.NE.4) THEN
21436                WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21437  1000         FORMAT(/,1X,'E_cm =',F9.1,' GeV  Q^2 =',F6.1,' GeV^2 :',/)
21438                WRITE(LOUT,1001) SIGTOT,ERRTOT
21439  1001          FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21440                WRITE(LOUT,1002) SIGELA,ERRELA
21441  1002          FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21442                WRITE(LOUT,1003) SIGQEP,ERRQEP
21443  1003          FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21444      &                F11.5,' mb')
21445                WRITE(LOUT,1004) SIGQET,ERRQET
21446  1004          FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21447      &                F11.5,' mb')
21448                WRITE(LOUT,1005) SIGQE2,ERRQE2
21449  1005          FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21450      &                ' +-',F11.5,' mb')
21451                WRITE(LOUT,1006) SIGPRO,ERRPRO
21452  1006          FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21453                WRITE(LOUT,1007) SIGDEL,ERRDEL
21454  1007          FORMAT(1X,'diff-el   ',27X,F10.4,' +-',F11.5,' mb')
21455                WRITE(LOUT,1008) SIGDQE,ERRDQE
21456  1008          FORMAT(1X,'diff-qel  ',27X,F10.4,' +-',F11.5,' mb')
21457             ENDIF
21458
21459     2    CONTINUE
21460     1 CONTINUE
21461
21462       RETURN
21463       END
21464
21465 *$ CREATE DT_SIGGA.FOR
21466 *COPY DT_SIGGA
21467 *
21468 *===sigga==============================================================*
21469 *
21470       SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21471
21472 ************************************************************************
21473 * Total/inelastic photon-nucleus cross sections.                       *
21474 *     !!!! Overwrites SHMAKI-initialization. Do not use it during      *
21475 *          production runs !!!!                                        *
21476 * This version dated 27.03.96 is written by S. Roesler                 *
21477 ************************************************************************
21478
21479       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21480       SAVE
21481
21482       PARAMETER ( LINP = 10 ,
21483      &            LOUT = 6 ,
21484      &            LDAT = 9 )
21485
21486       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21487      &           OHALF=0.5D0,ONE=1.0D0)
21488       PARAMETER (AMPROT = 0.938D0)
21489
21490       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21491
21492 * Glauber formalism: cross sections
21493       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21494      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21495      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21496      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21497      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21498      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21499      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21500      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21501      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21502      &                BSLOPE,NEBINI,NQBINI
21503
21504       NT  = NTI
21505       X   = XI
21506       Q2  = Q2I
21507       ECM = ECMI
21508       XNU = XNUI
21509       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21510      &   ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21511       CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21512       STOT  = XSTOT(1,1,1)
21513       ETOT  = XETOT(1,1,1)
21514       SIN   = XSPRO(1,1,1)
21515       EIN   = XEPRO(1,1,1)
21516
21517       RETURN
21518       END
21519
21520 *$ CREATE DT_SIGGAT.FOR
21521 *COPY DT_SIGGAT
21522 *
21523 *===siggat=============================================================*
21524 *
21525       SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21526
21527 ************************************************************************
21528 * Total/inelastic photon-nucleus cross sections.                       *
21529 * Uses pre-tabulated cross section.                                    *
21530 * This version dated 29.07.96 is written by S. Roesler                 *
21531 ************************************************************************
21532
21533       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21534       SAVE
21535
21536       PARAMETER ( LINP = 10 ,
21537      &            LOUT = 6 ,
21538      &            LDAT = 9 )
21539
21540       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21541      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21542
21543       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21544
21545 * Glauber formalism: cross sections
21546       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21547      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21548      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21549      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21550      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21551      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21552      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21553      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21554      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21555      &                BSLOPE,NEBINI,NQBINI
21556
21557       NTARG = ABS(NT)
21558       I1   = 1
21559       I2   = 1
21560       RATE = ONE
21561       IF (NEBINI.GT.1) THEN
21562          IF (ECMI.GE.ECMNN(NEBINI)) THEN
21563             I1   = NEBINI
21564             I2   = NEBINI
21565             RATE = ONE
21566          ELSEIF (ECMI.GT.ECMNN(1)) THEN
21567             DO 1 I=2,NEBINI
21568                IF (ECMI.LT.ECMNN(I)) THEN
21569                   I1   = I-1
21570                   I2   = I
21571                   RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21572                   GOTO 2
21573                ENDIF
21574     1       CONTINUE
21575     2       CONTINUE
21576          ENDIF
21577       ENDIF
21578       J1   = 1
21579       J2   = 1
21580       RATQ = ONE
21581       IF (NQBINI.GT.1) THEN
21582          IF (Q2I.GE.Q2G(NQBINI)) THEN
21583             J1   = NQBINI
21584             J2   = NQBINI
21585             RATQ = ONE
21586          ELSEIF (Q2I.GT.Q2G(1)) THEN
21587             DO 3 I=2,NQBINI
21588                IF (Q2I.LT.Q2G(I)) THEN
21589                   J1   = I-1
21590                   J2   = I
21591                   RATQ = LOG10(    Q2I/MAX(Q2G(J1),TINY14))/
21592      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21593 C                 RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21594                   GOTO 4
21595                ENDIF
21596     3       CONTINUE
21597     4       CONTINUE
21598          ENDIF
21599       ENDIF
21600
21601       STOT = XSTOT(I1,J1,NTARG)+
21602      &   RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21603      &   RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21604      &   RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21605      &              XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21606
21607       RETURN
21608       END
21609
21610 *$ CREATE DT_SANO.FOR
21611 *COPY DT_SANO
21612 *
21613 *===sigano=============================================================*
21614 *
21615       DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21616
21617 ************************************************************************
21618 * This version dated 31.07.96 is written by S. Roesler                 *
21619 ************************************************************************
21620
21621       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21622       SAVE
21623
21624       PARAMETER ( LINP = 10 ,
21625      &            LOUT = 6 ,
21626      &            LDAT = 9 )
21627
21628       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21629      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21630       PARAMETER (NE = 8)
21631
21632 * VDM parameter for photon-nucleus interactions
21633       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21634
21635 * properties of interacting particles
21636       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
21637
21638       DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
21639       DATA ECMANO /
21640      &             0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
21641      &             0.100D+04,0.200D+04,0.500D+04
21642      &            /
21643 * fixed cut (3 GeV/c)
21644       DATA FRAANO /
21645      &             0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
21646      &             0.062D+00,0.054D+00,0.042D+00
21647      &            /
21648       DATA SIGHRD /
21649      &           4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
21650      &           3.3086D-01,7.6255D-01,2.1319D+00
21651      &            /
21652 * running cut (based on obsolete Phojet-caluclations, bugs..)
21653 C     DATA FRAANO /
21654 C    &             0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
21655 C    &             0.167E+00,0.150E+00,0.131E+00
21656 C    &            /
21657 C     DATA SIGHRD /
21658 C    &           6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
21659 C    &           2.5736E-01,4.5593E-01,8.2550E-01
21660 C    &            /
21661
21662       DT_SANO = ZERO
21663       IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
21664       J1   = 0
21665       J2   = 0
21666       RATE = ONE
21667       IF (ECM.GE.ECMANO(NE)) THEN
21668          J1 = NE
21669          J2 = NE
21670       ELSEIF (ECM.GT.ECMANO(1)) THEN
21671          DO 1 IE=2,NE
21672             IF (ECM.LT.ECMANO(IE)) THEN
21673                J1   = IE-1
21674                J2   = IE
21675                RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
21676                GOTO 2
21677             ENDIF
21678     1    CONTINUE
21679     2    CONTINUE
21680       ENDIF
21681       IF ((J1.GT.0).AND.(J2.GT.0)) THEN
21682          AFRA1  = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
21683          AFRA2  = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
21684          DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
21685       ENDIF
21686
21687       RETURN
21688       END
21689
21690 *$ CREATE DT_SIGGP.FOR
21691 *COPY DT_SIGGP
21692 *
21693 *===siggp==============================================================*
21694 *
21695       SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
21696
21697 ************************************************************************
21698 * Total/inelastic photon-nucleon cross sections.                       *
21699 * This version dated 30.04.96 is written by S. Roesler                 *
21700 ************************************************************************
21701
21702       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21703       SAVE
21704
21705       PARAMETER ( LINP = 10 ,
21706      &            LOUT = 6 ,
21707      &            LDAT = 9 )
21708
21709       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21710       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
21711      &           PI     = TWOPI/TWO,
21712      &           GEV2MB = 0.38938D0,
21713      &           ALPHEM = ONE/137.0D0)
21714
21715 * particle properties (BAMJET index convention)
21716       CHARACTER*8  ANAME
21717       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21718      &                IICH(210),IIBAR(210),K1(210),K2(210)
21719
21720 * VDM parameter for photon-nucleus interactions
21721       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21722
21723 **PHOJET105a
21724 C     CHARACTER*8 MDLNA
21725 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
21726 C     PARAMETER (IEETAB=10)
21727 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21728 **PHOJET110
21729
21730 C  model switches and parameters
21731       CHARACTER*8 MDLNA
21732       INTEGER ISWMDL,IPAMDL
21733       DOUBLE PRECISION PARMDL
21734       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21735
21736 C  energy-interpolation table
21737       INTEGER IEETA2
21738       PARAMETER ( IEETA2 = 20 )
21739       INTEGER ISIMAX
21740       DOUBLE PRECISION SIGTAB,SIGECM
21741       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21742 **
21743
21744 C     PARAMETER (NPOINT=80)
21745       PARAMETER (NPOINT=16)
21746       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
21747
21748       STOT = ZERO
21749       SINE = ZERO
21750       SDIR = ZERO
21751
21752       W2 = ECMI**2
21753       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21754      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21755       Q2 = Q2I
21756       X  = XI
21757 * photoprod.
21758       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21759          Q2 = 0.0001D0
21760          X  = Q2/(W2+Q2-AAM(1)**2)
21761 * DIS
21762       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21763          X  = Q2/(W2+Q2-AAM(1)**2)
21764       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21765          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21766       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21767          W2 = Q2*(ONE-X)/X+AAM(1)**2
21768       ELSE
21769          WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
21770          STOP
21771       ENDIF
21772       ECM = SQRT(W2)
21773
21774       IF (MODEGA.EQ.1) THEN
21775          SCALE = SQRT(Q2)
21776          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21777      &                                                       IDPDF)
21778 C        W = SQRT(W2)
21779
21780 C        ALLMF2 = PHO_ALLM97(Q2,W)
21781
21782 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
21783          STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
21784          SINE = ZERO
21785          SDIR = ZERO
21786       ELSEIF (MODEGA.EQ.2) THEN
21787          IF (INTRGE(1).EQ.1) THEN
21788             AMLO2 = (3.0D0*AAM(13))**2
21789          ELSEIF (INTRGE(1).EQ.2) THEN
21790             AMLO2 = AAM(33)**2
21791          ELSE
21792             AMLO2 = AAM(96)**2
21793          ENDIF
21794          IF (INTRGE(2).EQ.1) THEN
21795             AMHI2 = W2/TWO
21796          ELSEIF (INTRGE(2).EQ.2) THEN
21797             AMHI2 = W2/4.0D0
21798          ELSE
21799             AMHI2 = W2
21800          ENDIF
21801          AMHI20 = (ECM-AAM(1))**2
21802          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
21803          XAMLO  = LOG( AMLO2+Q2 )
21804          XAMHI  = LOG( AMHI2+Q2 )
21805 **PHOJET105a
21806 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21807 **PHOJET112
21808
21809          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21810
21811 **
21812          SUM  = ZERO
21813          DO 1 J=1,NPOINT
21814             AM2 = EXP(ABSZX(J))-Q2
21815             IF (AM2.LT.16.0D0) THEN
21816                R = TWO
21817             ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
21818                R = 10.0D0/3.0D0
21819             ELSE
21820                R = 11.0D0/3.0D0
21821             ENDIF
21822 C           FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21823             FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21824      &            * (ONE+EPSPOL*Q2/AM2)
21825             SUM = SUM+WEIGHT(J)*FAC
21826     1    CONTINUE
21827          SINE = SUM
21828          SDIR = DT_SIGVP(X,Q2)
21829          STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
21830          SDIR = SDIR/(0.588D0+RL2+Q2)
21831 C        STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
21832       ELSEIF (MODEGA.EQ.3) THEN
21833          CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
21834       ELSEIF (MODEGA.EQ.4) THEN
21835 *  load cross sections from PHOJET interpolation table
21836          IP = 1
21837          IF(ECM.LE.SIGECM(IP,1)) THEN
21838            I1 = 1
21839            I2 = 1
21840          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21841            DO 2 I=2,ISIMAX
21842               IF (ECM.LE.SIGECM(IP,I)) GOTO 3
21843     2      CONTINUE
21844     3      CONTINUE
21845            I1 = I-1
21846            I2 = I
21847          ELSE
21848            WRITE(LOUT,'(/1X,A,2E12.3)')
21849      &       'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
21850            I1 = ISIMAX
21851            I2 = ISIMAX
21852          ENDIF
21853          FAC2 = ZERO
21854          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21855      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21856          FAC1 = ONE-FAC2
21857 *  cross section dependence on photon virtuality
21858          FSUP1 = ZERO
21859          DO 4 I=1,3
21860             FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
21861      &                                /(1.D0+Q2/PARMDL(30+I))**2
21862     4    CONTINUE
21863          FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
21864          FAC1  = FAC1*FSUP1
21865          FAC2  = FAC2*FSUP1
21866          FSUP2 = 1.0D0
21867          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21868          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21869          SDIR  = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
21870 **re:
21871          STOT  = STOT-SDIR
21872 **
21873          SDIR  = SDIR/(FSUP1*FSUP2)
21874 **re:
21875          STOT  = STOT+SDIR
21876 **
21877       ENDIF
21878
21879       RETURN
21880       END
21881
21882 *$ CREATE DT_SIGVEL.FOR
21883 *COPY DT_SIGVEL
21884 *
21885 *===sigvel=============================================================*
21886 *
21887       SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
21888
21889 ************************************************************************
21890 * Cross section for elastic vector meson production                    *
21891 * This version dated 10.05.96 is written by S. Roesler                 *
21892 ************************************************************************
21893
21894       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21895       SAVE
21896
21897       PARAMETER ( LINP = 10 ,
21898      &            LOUT = 6 ,
21899      &            LDAT = 9 )
21900
21901       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21902       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
21903      &           PI     = TWOPI/TWO,
21904      &           GEV2MB = 0.38938D0,
21905      &           ALPHEM = ONE/137.0D0)
21906
21907 * particle properties (BAMJET index convention)
21908       CHARACTER*8  ANAME
21909       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21910      &                IICH(210),IIBAR(210),K1(210),K2(210)
21911
21912 * VDM parameter for photon-nucleus interactions
21913       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21914
21915       W2 = ECMI**2
21916       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21917      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21918       Q2 = Q2I
21919       X  = XI
21920 * photoprod.
21921       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21922          Q2 = 0.0001D0
21923          X  = Q2/(W2+Q2-AAM(1)**2)
21924 * DIS
21925       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21926          X  = Q2/(W2+Q2-AAM(1)**2)
21927       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21928          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21929       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21930          W2 = Q2*(ONE-X)/X+AAM(1)**2
21931       ELSE
21932          WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
21933          STOP
21934       ENDIF
21935       ECM = SQRT(W2)
21936
21937       AMV  = AAM(IDXV)
21938       AMV2 = AMV**2
21939
21940       BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
21941      &        +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
21942       ROSH   = 0.1D0
21943       STOVP  = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
21944       SELVP  = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
21945
21946       IF (IDXV.EQ.33) THEN
21947          COUPL = 0.00365D0
21948       ELSE
21949          STOP
21950       ENDIF
21951       SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
21952       SIG2 = SELVP
21953       SVEL  = COUPL * (AMV2/(AMV2+Q2))**2
21954      &              * (ONE+EPSPOL*Q2/AMV2) * SELVP
21955
21956       RETURN
21957       END
21958
21959 *$ CREATE DT_SIGVP.FOR
21960 *COPY DT_SIGVP
21961 *
21962 *===sigvp==============================================================*
21963 *
21964       DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
21965
21966 ************************************************************************
21967 * sigma_Vp                                                             *
21968 ************************************************************************
21969
21970       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21971       SAVE
21972
21973       PARAMETER ( LINP = 10 ,
21974      &            LOUT = 6 ,
21975      &            LDAT = 9 )
21976
21977       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21978       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21979      &           PI    = TWOPI/TWO,
21980      &           GEV2MB = 0.38938D0,
21981      &           AMPROT = 0.938D0,
21982      &           ALPHEM = ONE/137.0D0)
21983
21984 * VDM parameter for photon-nucleus interactions
21985       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21986
21987       X  = XI
21988       Q2 = Q2I
21989       IF (XI.LE.ZERO)  X  = 0.0001D0
21990       IF (Q2I.LE.ZERO) Q2 = 0.0001D0
21991
21992       ECM    = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
21993
21994       SCALE = SQRT(Q2)
21995       IF (MODEGA.EQ.1) THEN
21996          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21997      &                                                       IDPDF)
21998 C        W = ECM
21999
22000 C        ALLMF2 = PHO_ALLM97(Q2,W)
22001
22002 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
22003 C        STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22004 C        DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22005          DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22006       ELSEIF (MODEGA.EQ.4) THEN
22007          CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22008 C        F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22009          DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22010       ELSE
22011          STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22012       ENDIF
22013
22014       RETURN
22015
22016       END
22017
22018 *$ CREATE DT_RRM2.FOR
22019 *COPY DT_RRM2
22020 *
22021 *===RRM2===============================================================*
22022 *
22023       DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22024
22025       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22026       SAVE
22027
22028       PARAMETER ( LINP = 10 ,
22029      &            LOUT = 6 ,
22030      &            LDAT = 9 )
22031
22032       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22033       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22034      &           PI    = TWOPI/TWO,
22035      &           GEV2MB = 0.38938D0)
22036
22037 * particle properties (BAMJET index convention)
22038       CHARACTER*8  ANAME
22039       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22040      &                IICH(210),IIBAR(210),K1(210),K2(210)
22041
22042 * VDM parameter for photon-nucleus interactions
22043       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22044
22045       S   = Q2*(ONE-X)/X+AAM(1)**2
22046       ECM = SQRT(S)
22047
22048       IF (INTRGE(1).EQ.1) THEN
22049          AMLO2 = (3.0D0*AAM(13))**2
22050       ELSEIF (INTRGE(1).EQ.2) THEN
22051          AMLO2 = AAM(33)**2
22052       ELSE
22053          AMLO2 = AAM(96)**2
22054       ENDIF
22055       IF (INTRGE(2).EQ.1) THEN
22056          AMHI2 = S/TWO
22057       ELSEIF (INTRGE(2).EQ.2) THEN
22058          AMHI2 = S/4.0D0
22059       ELSE
22060          AMHI2 = S
22061       ENDIF
22062       AMHI20 = (ECM-AAM(1))**2
22063       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22064
22065       AM1C2 = 16.0D0
22066       AM2C2 = 121.0D0
22067       IF (AMHI2.LE.AM1C2) THEN
22068          DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22069       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22070          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22071      &          10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22072       ELSE
22073          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22074      &          10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22075      &          11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22076       ENDIF
22077
22078       RETURN
22079       END
22080
22081 *$ CREATE DT_RM2.FOR
22082 *COPY DT_RM2
22083 *
22084 *===RM2================================================================*
22085 *
22086       DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22087
22088       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22089       SAVE
22090
22091       PARAMETER ( LINP = 10 ,
22092      &            LOUT = 6 ,
22093      &            LDAT = 9 )
22094
22095       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22096       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22097      &           PI    = TWOPI/TWO,
22098      &           GEV2MB = 0.38938D0)
22099
22100 * VDM parameter for photon-nucleus interactions
22101       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22102
22103       IF (RL2.LE.ZERO) THEN
22104          DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22105      &        (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22106      &         +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22107       ELSE
22108          TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22109          TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22110          DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22111      &       -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22112      &       +EPSPOL*(
22113      &         -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22114      &       -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22115       ENDIF
22116
22117       RETURN
22118       END
22119
22120 *$ CREATE DT_SAM2.FOR
22121 *COPY DT_SAM2
22122 *
22123 *===SAM2===============================================================*
22124 *
22125       DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22126
22127       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22128       SAVE
22129
22130       PARAMETER ( LINP = 10 ,
22131      &            LOUT = 6 ,
22132      &            LDAT = 9 )
22133
22134       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22135      &           TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22136       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22137      &           PI    = TWOPI/TWO,
22138      &           GEV2MB = 0.38938D0)
22139
22140 * particle properties (BAMJET index convention)
22141       CHARACTER*8  ANAME
22142       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22143      &                IICH(210),IIBAR(210),K1(210),K2(210)
22144
22145 * VDM parameter for photon-nucleus interactions
22146       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22147
22148       S = ECM**2
22149       IF (INTRGE(1).EQ.1) THEN
22150          AMLO2 = (3.0D0*AAM(13))**2
22151       ELSEIF (INTRGE(1).EQ.2) THEN
22152          AMLO2 = AAM(33)**2
22153       ELSE
22154          AMLO2 = AAM(96)**2
22155       ENDIF
22156       IF (INTRGE(2).EQ.1) THEN
22157          AMHI2 = S/TWO
22158       ELSEIF (INTRGE(2).EQ.2) THEN
22159          AMHI2 = S/4.0D0
22160       ELSE
22161          AMHI2 = S
22162       ENDIF
22163       AMHI20 = (ECM-AAM(1))**2
22164       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22165
22166       AM1C2 = 16.0D0
22167       AM2C2 = 121.0D0
22168       YLO   = LOG(AMLO2+Q2)
22169       YC1   = LOG(AM1C2+Q2)
22170       YC2   = LOG(AM2C2+Q2)
22171       YHI   = LOG(AMHI2+Q2)
22172       IF (AMHI2.LE.AM1C2) THEN
22173          FACHI = TWO
22174       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22175          FACHI = TENTRD
22176       ELSE
22177          FACHI = ELVTRD
22178       ENDIF
22179
22180     1 CONTINUE
22181       YSAM2  = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22182       IF (YSAM2.LE.YC1) THEN
22183          FAC = TWO
22184       ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22185          FAC = TENTRD
22186       ELSE
22187          FAC = ELVTRD
22188       ENDIF
22189       WEIGMX = FACHI*(ONE-Q2*EXP(  -YHI))
22190       XSAM2  = FAC  *(ONE-Q2*EXP(-YSAM2))
22191       IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22192
22193       DT_SAM2   = EXP(YSAM2)-Q2
22194
22195       RETURN
22196       END
22197
22198 *$ CREATE DT_CKMT.FOR
22199 *COPY DT_CKMT
22200 *
22201 *===ckmt===============================================================*
22202 *
22203       SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22204      &                F2,IPAR)
22205
22206 ************************************************************************
22207 * This version dated 31.01.96 is written by S. Roesler                 *
22208 ************************************************************************
22209
22210       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22211       SAVE
22212
22213       PARAMETER ( LINP = 10 ,
22214      &            LOUT = 6 ,
22215      &            LDAT = 9 )
22216
22217       PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22218
22219       PARAMETER (Q02 = 2.0D0,
22220      &           DQ2 = 10.05D0,
22221      &           Q12 = Q02+DQ2)
22222
22223       DIMENSION PD(-6:6),SEA(3),VAL(2)
22224
22225       CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22226       CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22227       ADQ2 = LOG10(Q12)-LOG10(Q02)
22228       F2P  = (F2Q1-F2Q0)/ADQ2
22229       CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22230       CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22231       F2PP = (F2PQ1-F2PQ0)/ADQ2
22232       FX   = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22233
22234       Q2     = MAX(SCALE**2.0D0,TINY10)
22235       SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22236       IF (Q2.LT.Q02) THEN
22237          CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22238          UPV  = VAL(1)
22239          DNV  = VAL(2)
22240          USEA = SEA(1)
22241          DSEA = SEA(2)
22242          STR  = SEA(3)
22243          CHM  = 0.0D0
22244          BOT  = 0.0D0
22245          TOP  = 0.0D0
22246          GL   = GLU
22247       ELSE
22248          CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22249          F2 = F2*SMOOTH
22250          UPV  = PD(2)-PD(3)
22251          DNV  = PD(1)-PD(3)
22252          USEA = PD(3)
22253          DSEA = PD(3)
22254          STR  = PD(3)
22255          CHM  = PD(4)
22256          BOT  = PD(5)
22257          TOP  = PD(6)
22258          GL   = PD(0)
22259 C        UPV  = UPV*SMOOTH
22260 C        DNV  = DNV*SMOOTH
22261 C        USEA = USEA*SMOOTH
22262 C        DSEA = DSEA*SMOOTH
22263 C        STR  = STR*SMOOTH
22264 C        CHM  = CHM*SMOOTH
22265 C        GL   = GL*SMOOTH
22266       ENDIF
22267
22268       RETURN
22269       END
22270 C
22271
22272 *$ CREATE DT_CKMTX.FOR
22273 *COPY DT_CKMTX
22274       SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22275 C**********************************************************************
22276 C
22277 C     PDF based on Regge theory, evolved with .... by ....
22278 C
22279 C     input: IPAR     2212   proton (not installed)
22280 C                       45   Pomeron
22281 C                      100   Deuteron
22282 C
22283 C     output: PD(-6:6) x*f(x)  parton distribution functions
22284 C            (PDFLIB convention: d = PD(1), u = PD(2) )
22285 C
22286 C**********************************************************************
22287
22288       SAVE
22289       DOUBLE PRECISION  X,SCALE2,PD(-6:6),CDN,CUP,F2
22290
22291       PARAMETER ( LINP = 10 ,
22292      &            LOUT = 6 ,
22293      &            LDAT = 9 )
22294
22295       DIMENSION QQ(7)
22296 C
22297       Q2=SNGL(SCALE2)
22298       Q1S=Q2
22299       XX=SNGL(X)
22300 C  QCD lambda for evolution
22301       OWLAM = 0.23D0
22302       OWLAM2=OWLAM**2
22303 C  Q0**2 for evolution
22304       Q02 = 2.D0
22305 C
22306 C
22307 C  the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22308 C                        q(6)=x*charm, q(7)=x*gluon
22309 C
22310       SB=0.
22311       IF(Q2-Q02) 1,1,2
22312     2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22313     1 CONTINUE
22314       IF(IPAR.EQ.2212) THEN
22315         CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22316         CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22317         CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22318         CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22319         CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22320         CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22321         CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22322 C     ELSEIF (IPAR.EQ.45) THEN
22323 C       CALL CKMTPO(1,0,XX,SB,QQ(1))
22324 C       CALL CKMTPO(2,0,XX,SB,QQ(2))
22325 C       CALL CKMTPO(3,0,XX,SB,QQ(3))
22326 C       CALL CKMTPO(4,0,XX,SB,QQ(4))
22327 C       CALL CKMTPO(5,0,XX,SB,QQ(5))
22328 C       CALL CKMTPO(8,0,XX,SB,QQ(6))
22329 C       CALL CKMTPO(7,0,XX,SB,QQ(7))
22330       ELSEIF (IPAR.EQ.100) THEN
22331         CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22332         CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22333         CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22334         CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22335         CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22336         CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22337         CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22338       ELSE
22339         WRITE(LOUT,'(1X,A,I4,A)')
22340      &     'CKMTX:   IPAR =',IPAR,' not implemented!'
22341         STOP
22342       ENDIF
22343 C
22344       PD(-6) = 0.D0
22345       PD(-5) = 0.D0
22346       PD(-4) = DBLE(QQ(6))
22347       PD(-3) = DBLE(QQ(3))
22348       PD(-2) = DBLE(QQ(4))
22349       PD(-1) = DBLE(QQ(5))
22350       PD(0)  = DBLE(QQ(7))
22351       PD(1)  = DBLE(QQ(2))
22352       PD(2)  = DBLE(QQ(1))
22353       PD(3)  = DBLE(QQ(3))
22354       PD(4)  = DBLE(QQ(6))
22355       PD(5)  = 0.D0
22356       PD(6)  = 0.D0
22357       IF(IPAR.EQ.45) THEN
22358         CDN = (PD(1)-PD(-1))/2.D0
22359         CUP = (PD(2)-PD(-2))/2.D0
22360         PD(-1) = PD(-1) + CDN
22361         PD(-2) = PD(-2) + CUP
22362         PD(1) = PD(-1)
22363         PD(2) = PD(-2)
22364       ENDIF
22365       F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22366      &     1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22367      &     1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22368       END
22369 C
22370
22371 *$ CREATE DT_PDF0.FOR
22372 *COPY DT_PDF0
22373 *
22374 *===pdf0===============================================================*
22375 *
22376       SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22377
22378 ************************************************************************
22379 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22380 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22381 *                   IPAR  = 2212   proton                              *
22382 *                         =  100   deuteron                            *
22383 * This version dated 31.01.96 is written by S. Roesler                 *
22384 ************************************************************************
22385
22386       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22387       SAVE
22388
22389       PARAMETER ( LINP = 10 ,
22390      &            LOUT = 6 ,
22391      &            LDAT = 9 )
22392
22393       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22394
22395       PARAMETER (
22396      &              AA     = 0.1502D0,
22397      &              BBDEU  = 1.2D0,
22398      &              BUD    = 0.754D0,
22399      &              BDD    = 0.4495D0,
22400      &              BUP    = 1.2064D0,
22401      &              BDP    = 0.1798D0,
22402      &              DELTA0 = 0.07684D0,
22403      &              D      = 1.117D0,
22404      &              C      = 3.5489D0,
22405      &              A      = 0.2631D0,
22406      &              B      = 0.6452D0,
22407      &              ALPHAR = 0.415D0,
22408      &              E      = 0.1D0
22409      &          )
22410
22411       PARAMETER (NPOINT=16)
22412 C     DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22413       DIMENSION SEA(3),VAL(2)
22414
22415       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22416       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22417 * proton, deuteron
22418       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22419          CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22420          SEA(1) = 0.75D0*SEA0
22421          SEA(2) = SEA(1)
22422          SEA(3) = SEA(1)
22423          VAL(1) = 9.0D0/4.0D0*VALU0
22424          VAL(2) = 9.0D0*VALD0
22425          GLU0   = SEA(1)/(1.0D0-X)
22426          F2     = SEA0+VALU0+VALD0
22427          F2PDF  = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22428      &            1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22429      &            1.0D0/9.0D0*(2.0D0*SEA(3))
22430          IF (ABS(F2-F2PDF).GT.TINY9) THEN
22431             WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22432             STOP
22433          ENDIF
22434 **PHOJET105a
22435 C        CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22436 **PHOJET112
22437
22438 C        CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22439
22440 **
22441 C        SUMQ = ZERO
22442 C        SUMG = ZERO
22443 C        DO 1 J=1,NPOINT
22444 C           CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22445 C           VALU0 = 9.0D0/4.0D0*VALU0
22446 C           VALD0 = 9.0D0*VALD0
22447 C           SEA0  = 0.75D0*SEA0
22448 C           SUMQ  = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22449 C           SUMG  = SUMG+ (SEA0/(1.0D0-ABSZX(J)))  *WEIGHT(J)
22450 C   1    CONTINUE
22451 C        GLU = GLU0*(1.0D0-SUMQ)/SUMG
22452       ELSE
22453          WRITE(LOUT,'(1X,A,I4,A)')
22454      &      'PDF0:   IPAR =',IPAR,' not implemented!'
22455          STOP
22456       ENDIF
22457
22458       RETURN
22459       END
22460
22461 *$ CREATE DT_CKMTQ0.FOR
22462 *COPY DT_CKMTQ0
22463 *
22464 *===ckmtq0=============================================================*
22465 *
22466       SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22467
22468 ************************************************************************
22469 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22470 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22471 *                   IPAR  = 2212   proton                              *
22472 *                         =  100   deuteron                            *
22473 * This version dated 31.01.96 is written by S. Roesler                 *
22474 ************************************************************************
22475
22476       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22477       SAVE
22478
22479       PARAMETER ( LINP = 10 ,
22480      &            LOUT = 6 ,
22481      &            LDAT = 9 )
22482
22483       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22484
22485       PARAMETER (
22486      &              AA     = 0.1502D0,
22487      &              BBDEU  = 1.2D0,
22488      &              BUD    = 0.754D0,
22489      &              BDD    = 0.4495D0,
22490      &              BUP    = 1.2064D0,
22491      &              BDP    = 0.1798D0,
22492      &              DELTA0 = 0.07684D0,
22493      &              D      = 1.117D0,
22494      &              C      = 3.5489D0,
22495      &              A      = 0.2631D0,
22496      &              B      = 0.6452D0,
22497      &              ALPHAR = 0.415D0,
22498      &              E      = 0.1D0
22499      &          )
22500
22501       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22502       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22503 * proton, deuteron
22504       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22505          IF (IPAR.EQ.2212) THEN
22506             BU = BUP
22507             BD = BDP
22508          ELSE
22509             BU = BUD
22510             BD = BDD
22511          ENDIF
22512          SEA0  = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22513      &          (Q2/(Q2+A))**(1.0D0+DELTA)
22514          VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22515      &           (Q2/(Q2+B))**(ALPHAR)
22516          VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22517      &           (Q2/(Q2+B))**(ALPHAR)
22518       ELSE
22519          WRITE(LOUT,'(1X,A,I4,A)')
22520      &      'CKMTQ0: IPAR =',IPAR,' not implemented!'
22521          STOP
22522       ENDIF
22523       RETURN
22524       END
22525 C
22526 C
22527
22528 *$ CREATE DT_CKMTDE.FOR
22529 *COPY DT_CKMTDE
22530       SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22531 C
22532 C**********************************************************************
22533 C    Deuteron - PDFs
22534 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22535 C    ANS = PDF(I)
22536 C    This version by S. Roesler, 30.01.96
22537 C**********************************************************************
22538
22539       SAVE
22540       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22541       EQUIVALENCE (GF(1,1,1),DL(1))
22542       DATA DELTA/.13/
22543 C
22544       DATA (DL(K),K=    1,   85) /
22545      &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22546      &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22547      &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22548      &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22549      &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22550      &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22551      &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22552      &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22553      &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22554      &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22555      &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22556      &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22557      &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22558      &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22559      &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22560      &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22561      &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22562       DATA (DL(K),K=   86,  170) /
22563      &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22564      &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22565      &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22566      &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22567      &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22568      &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22569      &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22570      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22571      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22572      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22573      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22574      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22579      &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22580       DATA (DL(K),K=  171,  255) /
22581      &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22582      &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22583      &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22584      &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22585      &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22586      &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22587      &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22588      &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22589      &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22590      &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22591      &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22592      &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22593      &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22594      &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22595      &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22596      &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22597      &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22598       DATA (DL(K),K=  256,  340) /
22599      &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22600      &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22601      &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22602      &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22603      &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22604      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22605      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22606      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22607      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22608      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22613      &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22614      &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22615      &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22616       DATA (DL(K),K=  341,  425) /
22617      &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22618      &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22619      &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22620      &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22621      &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22622      &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22623      &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22624      &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22625      &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22626      &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22627      &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22628      &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22629      &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22630      &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22631      &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22632      &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22633      &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22634       DATA (DL(K),K=  426,  510) /
22635      &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22636      &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22637      &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22638      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22639      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22640      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22641      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22642      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+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.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22647      &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22648      &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22649      &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22650      &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22651      &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22652       DATA (DL(K),K=  511,  595) /
22653      &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22654      &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22655      &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22656      &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22657      &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22658      &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22659      &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22660      &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22661      &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22662      &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22663      &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22664      &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22665      &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22666      &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22667      &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
22668      &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
22669      &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
22670       DATA (DL(K),K=  596,  680) /
22671      &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
22672      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22673      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22674      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22675      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22676      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+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.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22681      &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
22682      &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
22683      &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
22684      &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
22685      &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
22686      &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
22687      &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
22688       DATA (DL(K),K=  681,  765) /
22689      &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
22690      &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
22691      &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
22692      &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
22693      &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
22694      &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
22695      &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
22696      &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
22697      &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
22698      &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
22699      &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
22700      &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
22701      &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
22702      &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
22703      &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
22704      &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
22705      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22706       DATA (DL(K),K=  766,  850) /
22707      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22708      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22709      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22710      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22711      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
22715      &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
22716      &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
22717      &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
22718      &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
22719      &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
22720      &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
22721      &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
22722      &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
22723      &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
22724       DATA (DL(K),K=  851,  935) /
22725      &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
22726      &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
22727      &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
22728      &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
22729      &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
22730      &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
22731      &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
22732      &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
22733      &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
22734      &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
22735      &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
22736      &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
22737      &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
22738      &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
22739      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22740      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22741      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22742       DATA (DL(K),K=  936, 1020) /
22743      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22748      &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
22749      &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
22750      &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
22751      &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
22752      &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
22753      &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
22754      &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
22755      &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
22756      &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
22757      &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
22758      &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
22759      &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
22760       DATA (DL(K),K= 1021, 1105) /
22761      &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
22762      &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
22763      &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
22764      &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
22765      &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
22766      &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
22767      &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
22768      &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
22769      &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
22770      &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
22771      &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
22772      &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
22773      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22774      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22775      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22776      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22777      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22778       DATA (DL(K),K= 1106, 1190) /
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.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
22783      &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
22784      &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
22785      &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
22786      &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
22787      &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
22788      &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
22789      &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
22790      &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
22791      &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
22792      &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
22793      &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
22794      &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
22795      &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
22796       DATA (DL(K),K= 1191, 1275) /
22797      &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
22798      &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
22799      &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
22800      &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
22801      &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
22802      &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
22803      &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
22804      &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
22805      &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
22806      &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
22807      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22808      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22809      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22810      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22811      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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       DATA (DL(K),K= 1276, 1360) /
22815      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22816      &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
22817      &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
22818      &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
22819      &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
22820      &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
22821      &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
22822      &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
22823      &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
22824      &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
22825      &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
22826      &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
22827      &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
22828      &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
22829      &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
22830      &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
22831      &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
22832       DATA (DL(K),K= 1361, 1445) /
22833      &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
22834      &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
22835      &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
22836      &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
22837      &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
22838      &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
22839      &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
22840      &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
22841      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22842      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22843      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22844      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22845      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
22850       DATA (DL(K),K= 1446, 1530) /
22851      &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
22852      &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
22853      &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
22854      &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
22855      &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
22856      &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
22857      &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
22858      &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
22859      &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
22860      &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
22861      &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
22862      &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
22863      &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
22864      &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
22865      &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
22866      &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
22867      &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
22868       DATA (DL(K),K= 1531, 1615) /
22869      &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
22870      &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
22871      &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
22872      &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
22873      &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
22874      &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
22875      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22876      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22877      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22878      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22879      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
22884      &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
22885      &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
22886       DATA (DL(K),K= 1616, 1700) /
22887      &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
22888      &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
22889      &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
22890      &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
22891      &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
22892      &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
22893      &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
22894      &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
22895      &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
22896      &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
22897      &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
22898      &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
22899      &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
22900      &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
22901      &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
22902      &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
22903      &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
22904       DATA (DL(K),K= 1701, 1785) /
22905      &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
22906      &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
22907      &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
22908      &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
22909      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22910      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22911      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22912      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22913      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
22918      &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
22919      &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
22920      &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
22921      &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
22922       DATA (DL(K),K= 1786, 1870) /
22923      &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
22924      &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
22925      &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
22926      &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
22927      &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
22928      &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
22929      &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
22930      &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
22931      &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
22932      &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
22933      &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
22934      &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
22935      &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
22936      &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
22937      &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
22938      &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
22939      &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
22940       DATA (DL(K),K= 1871, 1955) /
22941      &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
22942      &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
22943      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22944      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22945      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22946      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22947      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
22952      &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
22953      &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
22954      &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
22955      &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
22956      &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
22957      &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
22958       DATA (DL(K),K= 1956, 2040) /
22959      &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
22960      &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
22961      &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
22962      &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
22963      &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
22964      &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
22965      &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
22966      &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
22967      &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
22968      &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
22969      &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
22970      &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
22971      &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
22972      &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
22973      &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
22974      &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
22975      &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
22976       DATA (DL(K),K= 2041, 2125) /
22977      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22978      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22979      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22980      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22981      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
22986      &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
22987      &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
22988      &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
22989      &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
22990      &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
22991      &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
22992      &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
22993      &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
22994       DATA (DL(K),K= 2126, 2210) /
22995      &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
22996      &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
22997      &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
22998      &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
22999      &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
23000      &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
23001      &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
23002      &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
23003      &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23004      &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23005      &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23006      &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23007      &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23008      &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23009      &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23010      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23011      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23012       DATA (DL(K),K= 2211, 2295) /
23013      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23014      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23018      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23019      &0.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23020      &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23021      &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23022      &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23023      &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23024      &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23025      &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23026      &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23027      &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23028      &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23029      &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23030       DATA (DL(K),K= 2296, 2380) /
23031      &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23032      &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23033      &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23034      &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23035      &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23036      &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23037      &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23038      &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23039      &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23040      &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23041      &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23042      &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23043      &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23044      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23045      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23046      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23047      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23048       DATA (DL(K),K= 2381, 2465) /
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      &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23054      &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23055      &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23056      &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23057      &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23058      &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23059      &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23060      &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23061      &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23062      &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23063      &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23064      &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23065      &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23066       DATA (DL(K),K= 2466, 2550) /
23067      &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23068      &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23069      &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23070      &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23071      &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23072      &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23073      &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23074      &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23075      &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23076      &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23077      &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23078      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23079      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23080      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23081      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23082      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23083      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23084       DATA (DL(K),K= 2551, 2635) /
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.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23088      &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23089      &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23090      &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23091      &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23092      &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23093      &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23094      &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23095      &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23096      &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23097      &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23098      &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23099      &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23100      &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23101      &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23102       DATA (DL(K),K= 2636, 2720) /
23103      &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23104      &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23105      &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23106      &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23107      &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23108      &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23109      &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23110      &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23111      &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23112      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23113      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23114      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23115      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23116      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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       DATA (DL(K),K= 2721, 2805) /
23121      &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23122      &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23123      &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23124      &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23125      &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23126      &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23127      &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23128      &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23129      &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23130      &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23131      &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23132      &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23133      &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23134      &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23135      &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23136      &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23137      &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23138       DATA (DL(K),K= 2806, 2890) /
23139      &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23140      &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23141      &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23142      &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23143      &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23144      &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23145      &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23146      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23147      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23148      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23149      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23150      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23155      &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23156       DATA (DL(K),K= 2891, 2975) /
23157      &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23158      &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23159      &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23160      &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23161      &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23162      &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23163      &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23164      &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23165      &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23166      &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23167      &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23168      &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23169      &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23170      &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23171      &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23172      &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23173      &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23174       DATA (DL(K),K= 2976, 3060) /
23175      &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23176      &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23177      &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23178      &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23179      &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23180      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23181      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23182      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23183      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23184      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23189      &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23190      &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23191      &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23192       DATA (DL(K),K= 3061, 3145) /
23193      &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23194      &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23195      &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23196      &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23197      &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23198      &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23199      &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23200      &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23201      &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23202      &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23203      &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23204      &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23205      &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23206      &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23207      &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23208      &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23209      &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23210       DATA (DL(K),K= 3146, 3230) /
23211      &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23212      &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23213      &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23214      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23215      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23216      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23217      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23218      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23223      &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23224      &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23225      &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23226      &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23227      &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23228       DATA (DL(K),K= 3231, 3315) /
23229      &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23230      &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23231      &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23232      &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23233      &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23234      &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23235      &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23236      &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23237      &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23238      &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23239      &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23240      &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23241      &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23242      &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23243      &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23244      &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23245      &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23246       DATA (DL(K),K= 3316, 3400) /
23247      &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23248      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23249      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23250      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23251      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23252      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23257      &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23258      &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23259      &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23260      &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23261      &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23262      &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23263      &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23264       DATA (DL(K),K= 3401, 3485) /
23265      &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23266      &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23267      &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23268      &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23269      &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23270      &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23271      &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23272      &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23273      &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23274      &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23275      &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23276      &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23277      &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23278      &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23279      &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23280      &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23281      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23282       DATA (DL(K),K= 3486, 3570) /
23283      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23284      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23285      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23286      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23287      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23291      &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23292      &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23293      &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23294      &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23295      &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23296      &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23297      &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23298      &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23299      &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23300       DATA (DL(K),K= 3571, 3655) /
23301      &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23302      &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23303      &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23304      &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23305      &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23306      &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23307      &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23308      &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23309      &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23310      &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23311      &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23312      &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23313      &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23314      &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23315      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23316      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23317      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23318       DATA (DL(K),K= 3656, 3740) /
23319      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23324      &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23325      &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23326      &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23327      &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23328      &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23329      &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23330      &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23331      &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23332      &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23333      &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23334      &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23335      &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23336       DATA (DL(K),K= 3741, 3825) /
23337      &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23338      &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23339      &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23340      &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23341      &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23342      &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23343      &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23344      &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23345      &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23346      &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23347      &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23348      &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23349      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23350      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23351      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23352      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23353      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23354       DATA (DL(K),K= 3826, 3910) /
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.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23359      &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23360      &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23361      &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23362      &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23363      &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23364      &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23365      &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23366      &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23367      &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23368      &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23369      &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23370      &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23371      &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23372       DATA (DL(K),K= 3911, 3995) /
23373      &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23374      &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23375      &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23376      &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23377      &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23378      &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23379      &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23380      &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23381      &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23382      &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23383      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23384      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23385      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23386      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23387      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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       DATA (DL(K),K= 3996, 4000) /
23391      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23392 C
23393       ANS = 0.
23394       IF (X.GT.0.9985) RETURN
23395       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23396 C
23397       IS  = S/DELTA+1
23398       IS1 = IS+1
23399       DO 1 L=1,25
23400          KL    = L+NDRV*25
23401          F1(L) = GF(I,IS,KL)
23402          F2(L) = GF(I,IS1,KL)
23403     1 CONTINUE
23404       A1 = DT_CKMTFF(X,F1)
23405       A2 = DT_CKMTFF(X,F2)
23406 C      A1=ALOG(A1)
23407 C      A2=ALOG(A2)
23408       S1  = (IS-1)*DELTA
23409       S2  = S1+DELTA
23410       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23411 C      ANS=EXP(ANS)
23412       RETURN
23413       END
23414 C
23415 C
23416
23417 *$ CREATE DT_CKMTPR.FOR
23418 *COPY DT_CKMTPR
23419       SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23420 C
23421 C**********************************************************************
23422 C    Proton   - PDFs
23423 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23424 C    ANS = PDF(I)
23425 C    This version by S. Roesler, 31.01.96
23426 C**********************************************************************
23427
23428       SAVE
23429       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23430       EQUIVALENCE (GF(1,1,1),DL(1))
23431       DATA DELTA/.10/
23432 C
23433       DATA (DL(K),K=    1,   85) /
23434      &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23435      &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23436      &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23437      &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23438      &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23439      &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23440      &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23441      &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23442      &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23443      &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23444      &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23445      &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23446      &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23447      &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23448      &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23449      &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23450      &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23451       DATA (DL(K),K=   86,  170) /
23452      &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23453      &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23454      &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23455      &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23456      &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23457      &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23458      &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23459      &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23460      &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23461      &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23462      &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23463      &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23464      &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23465      &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23466      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23467      &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23468      &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23469       DATA (DL(K),K=  171,  255) /
23470      &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23471      &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23472      &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23473      &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23474      &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23475      &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23476      &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23477      &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23478      &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23479      &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23480      &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23481      &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23482      &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23483      &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23484      &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23485      &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23486      &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23487       DATA (DL(K),K=  256,  340) /
23488      &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23489      &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23490      &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23491      &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23492      &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23493      &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23494      &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23495      &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23496      &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23497      &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23498      &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23499      &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23500      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23501      &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23502      &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23503      &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23504      &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23505       DATA (DL(K),K=  341,  425) /
23506      &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23507      &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23508      &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23509      &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23510      &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23511      &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23512      &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23513      &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23514      &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23515      &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23516      &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23517      &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23518      &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23519      &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23520      &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23521      &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23522      &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23523       DATA (DL(K),K=  426,  510) /
23524      &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23525      &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23526      &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23527      &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23528      &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23529      &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23530      &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23531      &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23532      &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23533      &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23534      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23535      &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23536      &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23537      &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23538      &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23539      &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23540      &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23541       DATA (DL(K),K=  511,  595) /
23542      &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23543      &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23544      &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23545      &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23546      &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23547      &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23548      &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23549      &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23550      &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23551      &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23552      &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23553      &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23554      &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23555      &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23556      &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23557      &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23558      &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23559       DATA (DL(K),K=  596,  680) /
23560      &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23561      &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23562      &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23563      &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23564      &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23565      &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23566      &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23567      &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23568      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23569      &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23570      &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23571      &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23572      &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23573      &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23574      &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23575      &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23576      &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23577       DATA (DL(K),K=  681,  765) /
23578      &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23579      &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23580      &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23581      &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23582      &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23583      &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23584      &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23585      &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23586      &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23587      &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23588      &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23589      &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23590      &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23591      &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23592      &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23593      &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23594      &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23595       DATA (DL(K),K=  766,  850) /
23596      &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23597      &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23598      &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23599      &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23600      &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23601      &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23602      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23603      &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23604      &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23605      &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23606      &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23607      &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23608      &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23609      &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23610      &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23611      &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23612      &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23613       DATA (DL(K),K=  851,  935) /
23614      &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23615      &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23616      &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23617      &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23618      &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23619      &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23620      &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23621      &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23622      &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23623      &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23624      &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23625      &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23626      &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23627      &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23628      &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23629      &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23630      &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23631       DATA (DL(K),K=  936, 1020) /
23632      &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23633      &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23634      &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23635      &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23636      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23637      &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23638      &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23639      &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23640      &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23641      &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23642      &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23643      &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23644      &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23645      &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23646      &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23647      &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23648      &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23649       DATA (DL(K),K= 1021, 1105) /
23650      &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23651      &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23652      &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23653      &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23654      &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23655      &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23656      &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23657      &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23658      &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23659      &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23660      &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23661      &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23662      &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23663      &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23664      &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23665      &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23666      &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23667       DATA (DL(K),K= 1106, 1190) /
23668      &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
23669      &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23670      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23671      &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23672      &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
23673      &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
23674      &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
23675      &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
23676      &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
23677      &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
23678      &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
23679      &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
23680      &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
23681      &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
23682      &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
23683      &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
23684      &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
23685       DATA (DL(K),K= 1191, 1275) /
23686      &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
23687      &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
23688      &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
23689      &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
23690      &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
23691      &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
23692      &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
23693      &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
23694      &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
23695      &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
23696      &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
23697      &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
23698      &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
23699      &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
23700      &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
23701      &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
23702      &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
23703       DATA (DL(K),K= 1276, 1360) /
23704      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23705      &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23706      &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
23707      &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
23708      &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
23709      &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
23710      &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
23711      &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
23712      &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
23713      &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
23714      &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
23715      &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
23716      &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
23717      &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
23718      &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
23719      &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
23720      &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
23721       DATA (DL(K),K= 1361, 1445) /
23722      &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
23723      &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
23724      &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
23725      &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
23726      &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
23727      &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
23728      &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
23729      &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
23730      &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
23731      &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
23732      &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
23733      &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
23734      &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
23735      &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
23736      &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23737      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23738      &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23739       DATA (DL(K),K= 1446, 1530) /
23740      &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
23741      &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
23742      &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
23743      &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
23744      &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
23745      &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
23746      &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
23747      &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
23748      &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
23749      &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
23750      &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
23751      &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
23752      &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
23753      &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
23754      &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
23755      &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
23756      &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
23757       DATA (DL(K),K= 1531, 1615) /
23758      &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
23759      &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
23760      &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
23761      &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
23762      &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
23763      &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
23764      &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
23765      &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
23766      &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
23767      &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
23768      &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
23769      &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
23770      &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23771      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23772      &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23773      &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
23774      &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
23775       DATA (DL(K),K= 1616, 1700) /
23776      &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
23777      &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
23778      &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
23779      &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
23780      &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
23781      &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
23782      &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
23783      &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
23784      &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
23785      &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
23786      &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
23787      &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
23788      &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
23789      &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
23790      &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
23791      &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
23792      &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
23793       DATA (DL(K),K= 1701, 1785) /
23794      &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
23795      &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
23796      &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
23797      &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
23798      &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
23799      &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
23800      &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
23801      &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
23802      &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
23803      &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
23804      &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23805      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23806      &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23807      &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
23808      &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
23809      &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
23810      &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
23811       DATA (DL(K),K= 1786, 1870) /
23812      &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
23813      &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
23814      &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
23815      &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
23816      &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
23817      &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
23818      &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
23819      &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
23820      &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
23821      &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
23822      &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
23823      &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
23824      &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
23825      &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
23826      &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
23827      &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
23828      &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
23829       DATA (DL(K),K= 1871, 1955) /
23830      &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
23831      &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
23832      &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
23833      &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
23834      &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
23835      &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
23836      &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
23837      &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
23838      &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23839      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23840      &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23841      &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
23842      &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
23843      &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
23844      &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
23845      &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
23846      &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
23847       DATA (DL(K),K= 1956, 2040) /
23848      &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
23849      &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
23850      &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
23851      &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
23852      &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
23853      &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
23854      &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
23855      &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
23856      &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
23857      &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
23858      &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
23859      &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
23860      &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
23861      &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
23862      &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
23863      &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
23864      &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
23865       DATA (DL(K),K= 2041, 2125) /
23866      &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
23867      &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
23868      &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
23869      &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
23870      &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
23871      &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
23872      &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23873      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23874      &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23875      &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
23876      &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
23877      &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
23878      &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
23879      &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
23880      &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
23881      &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
23882      &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
23883       DATA (DL(K),K= 2126, 2210) /
23884      &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
23885      &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
23886      &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
23887      &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
23888      &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
23889      &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
23890      &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
23891      &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
23892      &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
23893      &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
23894      &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
23895      &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
23896      &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
23897      &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
23898      &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
23899      &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
23900      &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
23901       DATA (DL(K),K= 2211, 2295) /
23902      &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
23903      &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
23904      &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
23905      &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
23906      &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23907      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23908      &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23909      &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
23910      &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
23911      &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
23912      &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
23913      &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
23914      &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
23915      &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
23916      &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
23917      &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
23918      &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
23919       DATA (DL(K),K= 2296, 2380) /
23920      &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
23921      &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
23922      &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
23923      &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
23924      &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
23925      &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
23926      &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
23927      &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
23928      &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
23929      &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
23930      &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
23931      &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
23932      &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
23933      &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
23934      &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
23935      &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
23936      &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
23937       DATA (DL(K),K= 2381, 2465) /
23938      &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
23939      &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
23940      &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23941      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23942      &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23943      &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
23944      &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
23945      &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
23946      &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
23947      &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
23948      &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
23949      &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
23950      &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
23951      &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
23952      &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
23953      &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
23954      &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
23955       DATA (DL(K),K= 2466, 2550) /
23956      &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
23957      &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
23958      &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
23959      &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
23960      &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
23961      &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
23962      &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
23963      &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
23964      &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
23965      &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
23966      &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
23967      &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
23968      &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
23969      &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
23970      &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
23971      &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
23972      &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
23973       DATA (DL(K),K= 2551, 2635) /
23974      &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
23975      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23976      &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
23977      &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
23978      &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
23979      &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
23980      &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
23981      &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
23982      &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
23983      &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
23984      &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
23985      &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
23986      &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
23987      &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
23988      &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
23989      &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
23990      &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
23991       DATA (DL(K),K= 2636, 2720) /
23992      &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
23993      &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
23994      &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
23995      &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
23996      &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
23997      &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
23998      &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
23999      &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
24000      &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
24001      &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
24002      &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
24003      &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24004      &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24005      &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24006      &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24007      &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24008      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24009       DATA (DL(K),K= 2721, 2805) /
24010      &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24011      &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24012      &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24013      &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24014      &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24015      &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24016      &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24017      &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24018      &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24019      &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24020      &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24021      &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24022      &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24023      &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24024      &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24025      &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24026      &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24027       DATA (DL(K),K= 2806, 2890) /
24028      &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24029      &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24030      &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24031      &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24032      &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24033      &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24034      &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24035      &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24036      &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24037      &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24038      &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24039      &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24040      &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24041      &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24042      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24043      &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24044      &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24045       DATA (DL(K),K= 2891, 2975) /
24046      &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24047      &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24048      &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24049      &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24050      &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24051      &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24052      &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24053      &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24054      &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24055      &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24056      &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24057      &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24058      &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24059      &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24060      &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24061      &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24062      &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24063       DATA (DL(K),K= 2976, 3060) /
24064      &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24065      &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24066      &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24067      &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24068      &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24069      &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24070      &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24071      &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24072      &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24073      &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24074      &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24075      &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24076      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24077      &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24078      &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24079      &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24080      &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24081       DATA (DL(K),K= 3061, 3145) /
24082      &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24083      &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24084      &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24085      &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24086      &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24087      &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24088      &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24089      &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24090      &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24091      &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24092      &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24093      &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24094      &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24095      &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24096      &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24097      &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24098      &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24099       DATA (DL(K),K= 3146, 3230) /
24100      &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24101      &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24102      &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24103      &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24104      &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24105      &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24106      &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24107      &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24108      &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24109      &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24110      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24111      &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24112      &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24113      &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24114      &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24115      &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24116      &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24117       DATA (DL(K),K= 3231, 3315) /
24118      &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24119      &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24120      &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24121      &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24122      &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24123      &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24124      &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24125      &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24126      &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24127      &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24128      &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24129      &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24130      &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24131      &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24132      &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24133      &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24134      &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24135       DATA (DL(K),K= 3316, 3400) /
24136      &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24137      &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24138      &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24139      &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24140      &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24141      &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24142      &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24143      &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24144      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24145      &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24146      &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24147      &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24148      &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24149      &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24150      &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24151      &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24152      &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24153       DATA (DL(K),K= 3401, 3485) /
24154      &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24155      &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24156      &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24157      &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24158      &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24159      &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24160      &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24161      &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24162      &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24163      &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24164      &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24165      &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24166      &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24167      &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24168      &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24169      &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24170      &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24171       DATA (DL(K),K= 3486, 3570) /
24172      &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24173      &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24174      &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24175      &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24176      &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24177      &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24178      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24179      &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24180      &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24181      &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24182      &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24183      &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24184      &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24185      &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24186      &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24187      &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24188      &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24189       DATA (DL(K),K= 3571, 3655) /
24190      &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24191      &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24192      &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24193      &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24194      &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24195      &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24196      &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24197      &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24198      &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24199      &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24200      &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24201      &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24202      &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24203      &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24204      &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24205      &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24206      &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24207       DATA (DL(K),K= 3656, 3740) /
24208      &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24209      &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24210      &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24211      &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24212      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24213      &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24214      &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24215      &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24216      &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24217      &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24218      &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24219      &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24220      &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24221      &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24222      &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24223      &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24224      &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24225       DATA (DL(K),K= 3741, 3825) /
24226      &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24227      &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24228      &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24229      &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24230      &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24231      &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24232      &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24233      &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24234      &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24235      &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24236      &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24237      &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24238      &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24239      &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24240      &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24241      &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24242      &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24243       DATA (DL(K),K= 3826, 3910) /
24244      &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24245      &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24246      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24247      &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24248      &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24249      &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24250      &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24251      &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24252      &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24253      &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24254      &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24255      &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24256      &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24257      &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24258      &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24259      &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24260      &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24261       DATA (DL(K),K= 3911, 3995) /
24262      &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24263      &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24264      &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24265      &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24266      &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24267      &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24268      &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24269      &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24270      &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24271      &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24272      &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24273      &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24274      &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24275      &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24276      &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24277      &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24278      &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24279       DATA (DL(K),K= 3996, 4000) /
24280      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24281 C
24282       ANS = 0.
24283       IF (X.GT.0.9985) RETURN
24284       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24285 C
24286       IS  = S/DELTA+1
24287       IS1 = IS+1
24288       DO 1 L=1,25
24289          KL    = L+NDRV*25
24290          F1(L) = GF(I,IS,KL)
24291          F2(L) = GF(I,IS1,KL)
24292     1 CONTINUE
24293       A1 = DT_CKMTFF(X,F1)
24294       A2 = DT_CKMTFF(X,F2)
24295 C      A1=ALOG(A1)
24296 C      A2=ALOG(A2)
24297       S1  = (IS-1)*DELTA
24298       S2  = S1+DELTA
24299       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24300 C      ANS=EXP(ANS)
24301       RETURN
24302       END
24303 C
24304
24305 *$ CREATE DT_CKMTFF.FOR
24306 *COPY DT_CKMTFF
24307       FUNCTION DT_CKMTFF(X,FVL)
24308 C**********************************************************************
24309 C
24310 C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24311 C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24312 C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24313 C     IN MAIN ROUTINE.
24314 C
24315 C**********************************************************************
24316
24317       SAVE
24318       DIMENSION FVL(25),XGRID(25)
24319       DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24320      *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24321 C
24322       DT_CKMTFF=0.
24323       DO 1 I=1,NX
24324       IF(X.LT.XGRID(I)) GO TO 2
24325     1 CONTINUE
24326     2 I=I-1
24327       IF(I.EQ.0) THEN
24328          I=I+1
24329       ELSE IF(I.GT.23) THEN
24330          I=23
24331       ENDIF
24332       J=I+1
24333       K=J+1
24334       AXI=LOG(XGRID(I))
24335       BXI=LOG(1.-XGRID(I))
24336       AXJ=LOG(XGRID(J))
24337       BXJ=LOG(1.-XGRID(J))
24338       AXK=LOG(XGRID(K))
24339       BXK=LOG(1.-XGRID(K))
24340       FI=LOG(ABS(FVL(I)) +1.E-15)
24341       FJ=LOG(ABS(FVL(J)) +1.E-16)
24342       FK=LOG(ABS(FVL(K)) +1.E-17)
24343       DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24344       ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24345      $ BXI))/DET
24346       ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24347       BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24348       IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24349      1RETURN
24350 C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24351 C         WRITE(6,2001) X,FVL
24352 C 2001    FORMAT(8E12.4)
24353 C         WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24354 C      ENDIF
24355       DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24356       RETURN
24357       END
24358
24359 *$ CREATE DT_FLUINI.FOR
24360 *COPY DT_FLUINI
24361 *
24362 *===fluini=============================================================*
24363 *
24364       SUBROUTINE DT_FLUINI
24365
24366 ************************************************************************
24367 * Initialisation of the nucleon-nucleon cross section fluctuation      *
24368 * treatment. The original version by J. Ranft.                         *
24369 * This version dated 21.04.95 is revised by S. Roesler.                *
24370 ************************************************************************
24371
24372       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24373       SAVE
24374
24375       PARAMETER ( LINP = 10 ,
24376      &            LOUT = 6 ,
24377      &            LDAT = 9 )
24378
24379       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24380
24381       PARAMETER ( A     = 0.1D0,
24382      &            B     = 0.893D0,
24383      &            OM    = 1.1D0,
24384      &            N     = 6,
24385      &            DX    = 0.003D0)
24386
24387 * n-n cross section fluctuations
24388       PARAMETER (NBINS = 1000)
24389       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24390       DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24391
24392       WRITE(LOUT,1000)
24393  1000 FORMAT(/,1X,'FLUINI:  hadronic cross section fluctuations ',
24394      &       'treated')
24395
24396       FLUSU  = ZERO
24397       FLUSUU = ZERO
24398
24399       DO 1 I=1,NBINS
24400          X        = DBLE(I)*DX
24401          FLUIX(I) = X
24402          FLUS     = ((X-B)/(OM*B))**N
24403          IF (FLUS.LE.20.0D0) THEN
24404             FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24405          ELSE
24406             FLUSI(I) = ZERO
24407          ENDIF
24408          FLUSU = FLUSU+FLUSI(I)
24409     1 CONTINUE
24410       DO 2 I=1,NBINS
24411          FLUSUU   = FLUSUU+FLUSI(I)/FLUSU
24412          FLUSI(I) = FLUSUU
24413     2 CONTINUE
24414
24415 C     WRITE(LOUT,1001)
24416 C1001 FORMAT(1X,'FLUCTUATIONS')
24417 C     CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24418
24419       DO 3 I=1,NBINS
24420          AF = DBLE(I)*0.001D0
24421          DO 4 J=1,NBINS
24422             IF (AF.LE.FLUSI(J)) THEN
24423                FLUIXX(I) = FLUIX(J)
24424                GOTO 5
24425             ENDIF
24426     4    CONTINUE
24427     5    CONTINUE
24428     3 CONTINUE
24429       FLUIXX(1)     = FLUIX(1)
24430       FLUIXX(NBINS) = FLUIX(NBINS)
24431
24432       RETURN
24433       END
24434
24435 *$ CREATE DT_SIGTBL.FOR
24436 *COPY DT_SIGTBL
24437 *
24438 *===sigtab=============================================================*
24439 *
24440       SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24441
24442 ************************************************************************
24443 * This version dated 18.11.95 is written by S. Roesler                 *
24444 ************************************************************************
24445
24446       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24447       SAVE
24448
24449       PARAMETER ( LINP = 10 ,
24450      &            LOUT = 6 ,
24451      &            LDAT = 9 )
24452
24453       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24454      &           OHALF=0.5D0,ONE=1.0D0)
24455       PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24456
24457       LOGICAL LINIT
24458
24459 * particle properties (BAMJET index convention)
24460       CHARACTER*8  ANAME
24461       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24462      &                IICH(210),IIBAR(210),K1(210),K2(210)
24463
24464       DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24465       DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24466      &             0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24467      &             0, 0, 5/
24468       DATA LINIT /.FALSE./
24469
24470 * precalculation and tabulation of elastic cross sections
24471       IF (ABS(MODE).EQ.1) THEN
24472          IF (MODE.EQ.1)
24473      &      OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24474          PLABLX = LOG10(PLO)
24475          PLABHX = LOG10(PHI)
24476          DPLAB  = (PLABHX-PLABLX)/DBLE(NBINS)
24477          DO 1 I=1,NBINS+1
24478             PLAB = PLABLX+DBLE(I-1)*DPLAB
24479             PLAB = 10**PLAB
24480             DO 2 IPROJ=1,23
24481                IDX = IDSIG(IPROJ)
24482                IF (IDX.GT.0) THEN
24483 C                 CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24484 C                 CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24485                   DUMZER = ZERO
24486                   CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24487                   CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24488                ENDIF
24489     2       CONTINUE
24490             IF (MODE.EQ.1) THEN
24491                WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24492      &                                (SIGEN(IDX,I),IDX=1,5)
24493  1000          FORMAT(F5.1,10F7.2)
24494             ENDIF
24495     1    CONTINUE
24496          IF (MODE.EQ.1) CLOSE(LDAT)
24497          LINIT = .TRUE.
24498       ELSE
24499          SIGE = -ONE
24500          IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24501      &                           .AND.(PTOT.LE.PHI) ) THEN
24502             IDX = IDSIG(JP)
24503             IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24504                PLABX = LOG10(PTOT)
24505                IF (PLABX.LE.PLABLX) THEN
24506                   I1 = 1
24507                   I2 = 1
24508                ELSEIF (PLABX.GE.PLABHX) THEN
24509                   I1 = NBINS+1
24510                   I2 = NBINS+1
24511                ELSE
24512                   I1 = INT((PLABX-PLABLX)/DPLAB)+1
24513                   I2 = I1+1
24514                ENDIF
24515                PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24516                PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24517                PBIN   = PLAB2X-PLAB1X
24518                IF (PBIN.GT.TINY10) THEN
24519                   RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24520                ELSE
24521                   RATX = ZERO
24522                ENDIF
24523                IF (JT.EQ.1) THEN
24524                   SIG1 = SIGEP(IDX,I1)
24525                   SIG2 = SIGEP(IDX,I2)
24526                ELSE
24527                   SIG1 = SIGEN(IDX,I1)
24528                   SIG2 = SIGEN(IDX,I2)
24529                ENDIF
24530                SIGE = SIG1+RATX*(SIG2-SIG1)
24531             ENDIF
24532          ENDIF
24533       ENDIF
24534
24535       RETURN
24536       END
24537
24538 *$ CREATE DT_XSTABL.FOR
24539 *COPY DT_XSTABL
24540 *
24541 *===xstabl=============================================================*
24542 *
24543       SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24544
24545       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24546       SAVE
24547
24548       PARAMETER ( LINP = 10 ,
24549      &            LOUT = 6 ,
24550      &            LDAT = 9 )
24551
24552       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24553      &           OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24554       LOGICAL LLAB,LELOG,LQLOG
24555
24556 * particle properties (BAMJET index convention)
24557       CHARACTER*8  ANAME
24558       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24559      &                IICH(210),IIBAR(210),K1(210),K2(210)
24560
24561 * properties of interacting particles
24562       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24563
24564       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24565
24566 * Glauber formalism: cross sections
24567       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24568      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24569      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24570      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24571      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24572      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24573      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24574      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24575      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24576      &                BSLOPE,NEBINI,NQBINI
24577
24578 * emulsion treatment
24579       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24580      &                NCOMPO,IEMUL
24581
24582       DIMENSION WHAT(6)
24583
24584       LLAB   = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24585       ELO    = ABS(WHAT(1))
24586       EHI    = ABS(WHAT(2))
24587       IF (ELO.GT.EHI) ELO = EHI
24588       LELOG  = WHAT(3).LT.ZERO
24589       NEBINS = MAX(INT(ABS(WHAT(3))),1)
24590       DEBINS = (EHI-ELO)/DBLE(NEBINS)
24591       IF (LELOG) THEN
24592          AELO   = LOG10(ELO)
24593          AEHI   = LOG10(EHI)
24594          ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24595       ENDIF
24596       Q2LO   = WHAT(4)
24597       Q2HI   = WHAT(5)
24598       IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24599       LQLOG  = WHAT(6).LT.ZERO
24600       NQBINS = MAX(INT(ABS(WHAT(6))),1)
24601       DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24602       IF (LQLOG) THEN
24603          AQ2LO  = LOG10(Q2LO)
24604          AQ2HI  = LOG10(Q2HI)
24605          ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24606       ENDIF
24607
24608       IF ( ELO.EQ. EHI) NEBINS = 0
24609       IF (Q2LO.EQ.Q2HI) NQBINS = 0
24610
24611       WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24612  1000 FORMAT(/,1X,'XSTABL:  E_lo  =',E10.3,' GeV  E_hi  =',E10.3,
24613      &       ' GeV     Lab = ',L1,'  qel: ',I2,/,10X,'Q2_lo =',F10.5,
24614      &       ' GeV^2  Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24615      &       '   A_p = ',I3,'   A_t = ',I3,/)
24616
24617 C     IF (IJPROJ.NE.7) THEN
24618          WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24619 * normalize fractions of emulsion components
24620          IF (NCOMPO.GT.0) THEN
24621             SUMFRA = ZERO
24622             DO 10 I=1,NCOMPO
24623                SUMFRA = SUMFRA+EMUFRA(I)
24624    10       CONTINUE
24625             IF (SUMFRA.GT.ZERO) THEN
24626                DO 11 I=1,NCOMPO
24627                   EMUFRA(I) = EMUFRA(I)/SUMFRA
24628    11          CONTINUE
24629             ENDIF
24630          ENDIF
24631 C     ELSE
24632 C        WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24633 C     ENDIF
24634       DO 1 I=1,NEBINS+1
24635          IF (LELOG) THEN
24636             E = 10**(AELO+DBLE(I-1)*ADEBIN)
24637          ELSE
24638             E = ELO+DBLE(I-1)*DEBINS
24639          ENDIF
24640          DO 2 J=1,NQBINS+1
24641             IF (LQLOG) THEN
24642                Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24643             ELSE
24644                Q2 = Q2LO+DBLE(J-1)*DQBINS
24645             ENDIF
24646 c            IF (IJPROJ.NE.7) THEN
24647                IF (LLAB) THEN
24648                   PLAB = ZERO
24649                   ECM  = ZERO
24650                   CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24651                ELSE
24652                   ECM = E
24653                ENDIF
24654                XI  = ZERO
24655                Q2I = ZERO
24656                IF (IJPROJ.EQ.7) Q2I = Q2
24657                IF (NCOMPO.GT.0) THEN
24658                   DO 20 IC=1,NCOMPO
24659                      IIT = IEMUMA(IC)
24660                      CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24661    20             CONTINUE
24662                ELSE
24663                   CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24664 C                 CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24665                ENDIF
24666                IF (NCOMPO.GT.0) THEN
24667                   XTOT = ZERO
24668                   ETOT = ZERO
24669                   XELA = ZERO
24670                   EELA = ZERO
24671                   XQEP = ZERO
24672                   EQEP = ZERO
24673                   XQET = ZERO
24674                   EQET = ZERO
24675                   XQE2 = ZERO
24676                   EQE2 = ZERO
24677                   XPRO = ZERO
24678                   EPRO = ZERO
24679                   XPRO1= ZERO
24680                   XDEL = ZERO
24681                   EDEL = ZERO
24682                   XDQE = ZERO
24683                   EDQE = ZERO
24684                   DO 21 IC=1,NCOMPO
24685                      XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
24686                      ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
24687                      XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
24688                      EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
24689                      XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
24690                      EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
24691                      XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
24692                      EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
24693                      XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
24694                      EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
24695                      XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
24696                      EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
24697                      XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
24698                      EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
24699                      XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
24700                      EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
24701                      YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
24702      &                     -XSQEP(1,1,IC)-XSQET(1,1,IC)
24703      &                     -XSQE2(1,1,IC)
24704                      XPRO1= XPRO1+EMUFRA(IC)*YPRO
24705    21             CONTINUE
24706                   ETOT = SQRT(ETOT)
24707                   EELA = SQRT(EELA)
24708                   EQEP = SQRT(EQEP)
24709                   EQET = SQRT(EQET)
24710                   EQE2 = SQRT(EQE2)
24711                   EPRO = SQRT(EPRO)
24712                   EDEL = SQRT(EDEL)
24713                   EDQE = SQRT(EDQE)
24714                   WRITE(LOUT,'(8E9.3)')
24715      &               E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
24716 C                 WRITE(LOUT,'(4E9.3)')
24717 C    &               E,XDEL,XDQE,XDEL+XDQE
24718                ELSE
24719                   WRITE(LOUT,'(11E10.3)')
24720      &              E,
24721      &              XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
24722      &              XSQE2(1,1,1),XSPRO(1,1,1),
24723      &              XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
24724      &             -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
24725      &              XSDEL(1,1,1)+XSDQE(1,1,1)
24726 C                 WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
24727 C    &                                    XSDEL(1,1,1)+XSDQE(1,1,1)
24728                ENDIF
24729 c            ELSE
24730 c               IF (LLAB) THEN
24731 c                  IF (IT.GT.1) THEN
24732 c                     IF (IXSQEL.EQ.0) THEN
24733 cC                       CALL DT_SIGGA(IT,  Q2, E,ZERO,ZERO,
24734 cC                       CALL DT_SIGGA(IT,   E,Q2,ZERO,ZERO,
24735 c                        CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
24736 c     &                             STOT,ETOT,SIN,EIN,STOT0)
24737 c                        IF (IRATIO.EQ.1) THEN
24738 c                           CALL DT_SIGGP(  Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
24739 cC                          CALL DT_SIGGP(   E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
24740 cC                          CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
24741 c*!! save cross sections
24742 c                           STOTA = STOT
24743 c                           ETOTA = ETOT
24744 c                           STOTP = STGP
24745 c*!!
24746 c                           STOT  = STOT/(DBLE(IT)*STGP)
24747 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
24748 c                           STOT0 = STGP
24749 c                           ETOT  = ZERO
24750 c                           EIN   = ZERO
24751 c                        ENDIF
24752 c                     ELSE
24753 c                        WRITE(LOUT,*)
24754 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
24755 c                        STOP
24756 c                     ENDIF
24757 c                  ELSE
24758 c                     ETOT = ZERO
24759 c                     EIN  = ZERO
24760 c                     STOT0= ZERO
24761 c                     IF (IXSQEL.EQ.0) THEN
24762 c                        CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
24763 c                     ELSE
24764 c                       SIN = ZERO
24765 c                       CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
24766 c                     ENDIF
24767 c                  ENDIF
24768 c               ELSE
24769 c                  IF (IT.GT.1) THEN
24770 c                     IF (IXSQEL.EQ.0) THEN
24771 c                        CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
24772 c     &                             STOT,ETOT,SIN,EIN,STOT0)
24773 c                        IF (IRATIO.EQ.1) THEN
24774 c                           CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
24775 c*!! save cross sections
24776 c                           STOTA = STOT
24777 c                           ETOTA = ETOT
24778 c                           STOTP = STGP
24779 c*!!
24780 c                           STOT  = STOT/(DBLE(IT)*STGP)
24781 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
24782 c                           STOT0 = STGP
24783 c                           ETOT  = ZERO
24784 c                           EIN   = ZERO
24785 c                        ENDIF
24786 c                     ELSE
24787 c                        WRITE(LOUT,*)
24788 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
24789 c                        STOP
24790 c                     ENDIF
24791 c                  ELSE
24792 c                     ETOT = ZERO
24793 c                     EIN  = ZERO
24794 c                     STOT0= ZERO
24795 c                     IF (IXSQEL.EQ.0) THEN
24796 c                        CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
24797 c                     ELSE
24798 c                       SIN = ZERO
24799 c                       CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
24800 c                     ENDIF
24801 c                  ENDIF
24802 c               ENDIF
24803 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
24804 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
24805 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
24806 c               WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
24807 c            ENDIF
24808     2    CONTINUE
24809     1 CONTINUE
24810
24811       RETURN
24812       END
24813
24814 *$ CREATE DT_TESTXS.FOR
24815 *COPY DT_TESTXS
24816 *
24817 *===testxs=============================================================*
24818 *
24819       SUBROUTINE DT_TESTXS
24820
24821       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24822       SAVE
24823
24824       DIMENSION XSTOT(26,2),XSELA(26,2)
24825
24826       OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
24827       OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
24828       OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
24829       OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
24830       DUMECM = 0.0D0
24831       PLABL = 0.01D0
24832       PLABH = 10000.0D0
24833       NBINS = 120
24834       APLABL = LOG10(PLABL)
24835       APLABH = LOG10(PLABH)
24836       ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
24837       DO 1 I=1,NBINS+1
24838          ADP = APLABL+DBLE(I-1)*ADPLAB
24839          P = 10.0D0**ADP
24840          DO 2 J=1,26
24841             CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
24842             CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
24843     2    CONTINUE
24844          WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
24845          WRITE(11,1000) P,(XSELA(K,1),K=1,26)
24846          WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
24847          WRITE(13,1000) P,(XSELA(K,2),K=1,26)
24848     1 CONTINUE
24849  1000 FORMAT(F8.3,26F9.3)
24850
24851       RETURN
24852       END
24853 ************************************************************************
24854 *                                                                      *
24855 *  DTUNUC 2.0:   library routines                                      *
24856 *                                   processed by S. Roesler, 6.5.95    *
24857 *                                                                      *
24858 ************************************************************************
24859 *
24860 *     1) Handling of parton momenta
24861 *          SUBROUTINE MASHEL
24862 *          SUBROUTINE DFERMI
24863 *
24864 *     2) Handling of parton flavors and particle indices
24865 *          INTEGER FUNCTION IPDG2B
24866 *          INTEGER FUNCTION IB2PDG
24867 *          INTEGER FUNCTION IQUARK
24868 *          INTEGER FUNCTION IBJQUA
24869 *          INTEGER FUNCTION ICIHAD
24870 *          INTEGER FUNCTION IPDGHA
24871 *          INTEGER FUNCTION MCHAD
24872 *          SUBROUTINE FLAHAD
24873 *
24874 *     3) Energy-momentum and quantum number conservation check routines
24875 *          SUBROUTINE EMC1
24876 *          SUBROUTINE EMC2
24877 *          SUBROUTINE EVTEMC
24878 *          SUBROUTINE EVTFLC
24879 *          SUBROUTINE EVTCHG
24880 *
24881 *     4) Transformations
24882 *          SUBROUTINE LTINI
24883 *          SUBROUTINE LTRANS
24884 *          SUBROUTINE LTNUC
24885 *          SUBROUTINE DALTRA
24886 *          SUBROUTINE DTRAFO
24887 *          SUBROUTINE STTRAN
24888 *          SUBROUTINE MYTRAN
24889 *          SUBROUTINE LT2LAO
24890 *          SUBROUTINE LT2LAB
24891 *
24892 *     5) Sampling from distributions
24893 *          INTEGER FUNCTION NPOISS
24894 *          DOUBLE PRECISION FUNCTION SAMPXB
24895 *          DOUBLE PRECISION FUNCTION SAMPEX
24896 *          DOUBLE PRECISION FUNCTION SAMSQX
24897 *          DOUBLE PRECISION FUNCTION BETREJ
24898 *          DOUBLE PRECISION FUNCTION DGAMRN
24899 *          DOUBLE PRECISION FUNCTION DBETAR
24900 *          SUBROUTINE RANNOR
24901 *          SUBROUTINE DPOLI
24902 *          SUBROUTINE DSFECF
24903 *          SUBROUTINE RACO
24904 *
24905 *     6) Special functions, algorithms and service routines
24906 *          DOUBLE PRECISION FUNCTION YLAMB
24907 *          SUBROUTINE SORT
24908 *          SUBROUTINE SORT1
24909 *          SUBROUTINE DT_XTIME
24910 *
24911 *     7) Random number generator package
24912 *          DOUBLE PRECISION FUNCTION DT_RNDM
24913 *          SUBROUTINE DT_RNDMST
24914 *          SUBROUTINE DT_RNDMIN
24915 *          SUBROUTINE DT_RNDMOU
24916 *          SUBROUTINE DT_RNDMTE
24917 *
24918 ************************************************************************
24919 *                                                                      *
24920 *                 1) Handling of parton momenta                        *
24921 *                                                                      *
24922 ************************************************************************
24923 *$ CREATE DT_MASHEL.FOR
24924 *COPY DT_MASHEL
24925 *
24926 *===mashel=============================================================*
24927 *
24928       SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
24929
24930 ************************************************************************
24931 *                                                                      *
24932 *    rescaling of momenta of two partons to put both                   *
24933 *                                       on mass shell                  *
24934 *                                                                      *
24935 *    input:       PA1,PA2   input momentum vectors                     *
24936 *                 XM1,2     desired masses of particles afterwards     *
24937 *                 P1,P2     changed momentum vectors                   *
24938 *                                                                      *
24939 * The original version is written by R. Engel.                         *
24940 * This version dated 12.12.94 is modified by S. Roesler.               *
24941 ************************************************************************
24942
24943       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24944       SAVE
24945
24946       PARAMETER ( LINP = 10 ,
24947      &            LOUT = 6 ,
24948      &            LDAT = 9 )
24949
24950       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
24951
24952       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
24953
24954       IREJ = 0
24955
24956 * Lorentz transformation into system CMS
24957       PX  = PA1(1)+PA2(1)
24958       PY  = PA1(2)+PA2(2)
24959       PZ  = PA1(3)+PA2(3)
24960       EE  = PA1(4)+PA2(4)
24961       XPTOT = SQRT(PX**2+PY**2+PZ**2)
24962       XMS   = (EE-XPTOT)*(EE+XPTOT)
24963       IF(XMS.LT.(XM1+XM2)**2) THEN
24964 C        WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
24965          GOTO 9999
24966       ENDIF
24967       XMS = SQRT(XMS)
24968       BGX = PX/XMS
24969       BGY = PY/XMS
24970       BGZ = PZ/XMS
24971       GAM = EE/XMS
24972       CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
24973      &           PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
24974 * rotation angles
24975       COD = P1(3)/PTOT1
24976 C     SID = SQRT((ONE-COD)*(ONE+COD))
24977       PPT = SQRT(P1(1)**2+P1(2)**2)
24978       SID = PPT/PTOT1
24979       COF = ONE
24980       SIF = ZERO
24981       IF(PTOT1*SID.GT.TINY10) THEN
24982          COF   = P1(1)/(SID*PTOT1)
24983          SIF   = P1(2)/(SID*PTOT1)
24984          ANORF = SQRT(COF*COF+SIF*SIF)
24985          COF   = COF/ANORF
24986          SIF   = SIF/ANORF
24987       ENDIF
24988 * new CM momentum and energies (for masses XM1,XM2)
24989       XM12 = SIGN(XM1**2,XM1)
24990       XM22 = SIGN(XM2**2,XM2)
24991       SS   = XMS**2
24992       PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
24993       EE1  = SQRT(XM12+PCMP**2)
24994       EE2  = XMS-EE1
24995 * back rotation
24996       MODE = 1
24997       CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
24998       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
24999      &            PTOT1,P1(1),P1(2),P1(3),P1(4))
25000       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
25001      &            PTOT2,P2(1),P2(2),P2(3),P2(4))
25002 * check consistency
25003       DEL = XMS*0.0001D0
25004       IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25005         IDEV = 1
25006       ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25007         IDEV = 2
25008       ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25009         IDEV = 3
25010       ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25011         IDEV = 4
25012       ELSE
25013         IDEV = 0
25014       ENDIF
25015       IF (IDEV.NE.0) THEN
25016          WRITE(LOUT,'(/1X,A,I3)')
25017      &      'MASHEL: inconsistent transformation',IDEV
25018          WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25019          WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25020          WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25021          WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25022          WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25023          WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25024       ENDIF
25025       RETURN
25026
25027  9999 CONTINUE
25028       IREJ = 1
25029       RETURN
25030       END
25031
25032 *$ CREATE DT_DFERMI.FOR
25033 *COPY DT_DFERMI
25034 *
25035 *===dfermi=============================================================*
25036 *
25037       SUBROUTINE DT_DFERMI(GPART)
25038
25039 ************************************************************************
25040 * Find largest of three random numbers.                                *
25041 ************************************************************************
25042
25043       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25044       SAVE
25045
25046       DIMENSION G(3)
25047
25048       DO 10 I=1,3
25049         G(I)=DT_RNDM(GPART)
25050    10 CONTINUE
25051       IF (G(3).LT.G(2)) GOTO 40
25052       IF (G(3).LT.G(1)) GOTO 30
25053       GPART = G(3)
25054    20 RETURN
25055    30 GPART = G(1)
25056       GOTO 20
25057    40 IF (G(2).LT.G(1)) GOTO 30
25058       GPART = G(2)
25059       GOTO 20
25060
25061       END
25062
25063 ************************************************************************
25064 *                                                                      *
25065 *         2) Handling of parton flavors and particle indices           *
25066 *                                                                      *
25067 ************************************************************************
25068 *$ CREATE IDT_IPDG2B.FOR
25069 *COPY IDT_IPDG2B
25070 *
25071 *===ipdg2b=============================================================*
25072 *
25073       INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25074
25075 ************************************************************************
25076 *                                                                      *
25077 *     conversion of quark numbering scheme                             *
25078 *                                                                      *
25079 *     input:   PDG parton numbering                                    *
25080 *              for diquarks:  NN number of the constituent quark       *
25081 *                             (e.g. ID=2301,NN=1 -> ICONV2=1)          *
25082 *                                                                      *
25083 *     output:  BAMJET particle codes                                   *
25084 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25085 *              2 d     8 a-d             -2 a-d                        *
25086 *              3 s     9 a-s             -3 a-s                        *
25087 *              4 c    10 a-c             -4 a-c                        *
25088 *                                                                      *
25089 * This is a modified version of ICONV2 written by R. Engel.            *
25090 * This version dated 13.12.94 is written by S. Roesler.                *
25091 ************************************************************************
25092
25093       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25094       SAVE
25095
25096       PARAMETER ( LINP = 10 ,
25097      &            LOUT = 6 ,
25098      &            LDAT = 9 )
25099
25100       IDA = ABS(ID)
25101 * diquarks
25102       IF (IDA.GT.6) THEN
25103         KF  = 3
25104         IF (IDA.GE.1000) KF = 4
25105         IDA = IDA/(10**(KF-NN))
25106         IDA = MOD(IDA,10)
25107       ENDIF
25108 * exchange up and dn quarks
25109       IF (IDA.EQ.1) THEN
25110         IDA = 2
25111       ELSEIF (IDA.EQ.2) THEN
25112         IDA = 1
25113       ENDIF
25114 * antiquarks
25115       IF (ID.LT.0) THEN
25116          IF (MODE.EQ.1) THEN
25117             IDA = IDA+6
25118          ELSE
25119             IDA = -IDA
25120          ENDIF
25121       ENDIF
25122       IDT_IPDG2B = IDA
25123
25124       RETURN
25125       END
25126
25127 *$ CREATE IDT_IB2PDG.FOR
25128 *COPY IDT_IB2PDG
25129 *
25130 *===ib2pdg=============================================================*
25131 *
25132       INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25133
25134 ************************************************************************
25135 *                                                                      *
25136 *     conversion of quark numbering scheme                             *
25137 *                                                                      *
25138 *     input:   BAMJET particle codes                                   *
25139 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25140 *              2 d     8 a-d             -2 a-d                        *
25141 *              3 s     9 a-s             -3 a-s                        *
25142 *              4 c    10 a-c             -4 a-c                        *
25143 *                                                                      *
25144 *     output:  PDG parton numbering                                    *
25145 *                                                                      *
25146 * This version dated 13.12.94 is written by S. Roesler.                *
25147 ************************************************************************
25148
25149       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25150       SAVE
25151
25152       PARAMETER ( LINP = 10 ,
25153      &            LOUT = 6 ,
25154      &            LDAT = 9 )
25155
25156       DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25157       DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25158       DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25159      &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25160      &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25161
25162       IDA = ID1
25163       IDB = ID2
25164       IF (MODE.EQ.1) THEN
25165          IF (ID1.GT.6) IDA = -(ID1-6)
25166          IF (ID2.GT.6) IDB = -(ID2-6)
25167       ENDIF
25168       IF (ID2.EQ.0) THEN
25169          IDT_IB2PDG = IHKKQ(IDA)
25170       ELSE
25171          IDT_IB2PDG = IHKKQQ(IDA,IDB)
25172       ENDIF
25173
25174       RETURN
25175       END
25176
25177 *$ CREATE IDT_IQUARK.FOR
25178 *COPY IDT_IQUARK
25179 *
25180 *===ipdgqu=============================================================*
25181 *
25182       INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25183
25184 ************************************************************************
25185 *                                                                      *
25186 *     quark contents according to PDG conventions                      *
25187 *     (random selection in case of quark mixing)                       *
25188 *                                                                      *
25189 *     input:   IDBAMJ BAMJET particle code                             *
25190 *              K      1..3   quark number                              *
25191 *                                                                      *
25192 *     output:  1   d  (anti --> neg.)                                  *
25193 *              2   u                                                   *
25194 *              3   s                                                   *
25195 *              4   c                                                   *
25196 *                                                                      *
25197 * This version written by R. Engel.                                    *
25198 ************************************************************************
25199
25200       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25201       SAVE
25202
25203       IQ = IDT_IBJQUA(K,IDBAMJ)
25204 * quark-antiquark
25205       IF (IQ.GT.6) THEN
25206          IQ = 6-IQ
25207       ENDIF
25208 * exchange of up and down
25209       IF (ABS(IQ).EQ.1) THEN
25210          IQ = SIGN(2,IQ)
25211       ELSEIF (ABS(IQ).EQ.2) THEN
25212          IQ = SIGN(1,IQ)
25213       ENDIF
25214       IDT_IQUARK = IQ
25215
25216       RETURN
25217       END
25218
25219 *$ CREATE IDT_IBJQUA.FOR
25220 *COPY IDT_IBJQUA
25221 *
25222 *===ibamq==============================================================*
25223 *
25224       INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25225
25226 ************************************************************************
25227 *                                                                      *
25228 *     quark contents according to BAMJET conventions                   *
25229 *     (random selection in case of quark mixing)                       *
25230 *                                                                      *
25231 *     input:   IDBAMJ BAMJET particle code                             *
25232 *              K      1..3   quark number                              *
25233 *                                                                      *
25234 *     output:  1   u      7   u bar                                    *
25235 *              2   d      8   d bar                                    *
25236 *              3   s      9   s bar                                    *
25237 *              4   c     10   c bar                                    *
25238 *                                                                      *
25239 * This version written by R. Engel.                                    *
25240 ************************************************************************
25241
25242       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25243       SAVE
25244
25245       DIMENSION ITAB(3,210)
25246       DATA ((ITAB(I,K),I=1,3),K=1,30) /
25247      &    1,  1,  2,   7,  7,  8,   0,  0,  0,
25248      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25249      &    0,  0,  0,   1,  2,  2,   7,  8,  8,
25250 *sr 10.1.94
25251 C    &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25252      &    0,  0,  0,   0,  0,  0,   3,  8,  0,
25253 *
25254      &    1,  8,  0,   2,  7,  0,   1,  9,  0,
25255 *sr 10.1.94
25256 C    &    3,  7,  0,   0,  0,  0,   0,  0,  0,
25257      &    3,  7,  0,   3,  1,  2,   9,  7,  8,
25258 *sr 10.1.94
25259 C    &    0,  0,  0,   2,  2,  3,   1,  1,  3,
25260      &    2,  9,  0,   2,  2,  3,   1,  1,  3,
25261 *
25262      &    1,  2,  3, 201,202,  0,   2,  9,  0,
25263      &    3,  8,  0,   0,  0,  0,   0,  0,  0,
25264      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25265       DATA ((ITAB(I,K),I=1,3),K=31,60) /
25266      &    3,  9,  0,   1,  8,  0, 203,204,  0,
25267      &    2,  7,  0,   0,  0,  0,   1,  9,  0,
25268      &    2,  9,  0,   3,  7,  0,   3,  8,  0,
25269      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25270      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25271      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25272      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25273      &    0,  0,  0,   1,  1,  1,   1,  1,  2,
25274      &    1,  2,  2,   2,  2,  2,   0,  0,  0,
25275      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25276       DATA ((ITAB(I,K),I=1,3),K=61,90) /
25277      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25278      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25279      &    7,  7,  7,   7,  7,  8,   7,  8,  8,
25280      &    8,  8,  8,   0,  0,  0,   0,  0,  0,
25281      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25282      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25283      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25284      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25285      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25286      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25287       DATA ((ITAB(I,K),I=1,3),K=91,120) /
25288      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25289      &    0,  0,  0,   0,  0,  0,   3,  9,  0,
25290      &    1,  3,  3,   2,  3,  3,   7,  7,  9,
25291      &    7,  8,  9,   8,  8,  9,   7,  9,  9,
25292      &    8,  9,  9,   1,  1,  3,   1,  2,  3,
25293      &    2,  2,  3,   1,  3,  3,   2,  3,  3,
25294      &    3,  3,  3,   7,  7,  9,   7,  8,  9,
25295      &    8,  8,  9,   7,  9,  9,   8,  9,  9,
25296      &    9,  9,  9,   4,  7,  0,   4,  8,  0,
25297      &    2, 10,  0,   1, 10,  0,   4,  9,  0 /
25298       DATA ((ITAB(I,K),I=1,3),K=121,150) /
25299      &    3, 10,  0,   4, 10,  0,   4,  7,  0,
25300      &    4,  8,  0,   2, 10,  0,   1, 10,  0,
25301      &    4,  9,  0,   3, 10,  0,   4, 10,  0,
25302      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25303      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25304      &    0,  0,  0,   1,  2,  4,   1,  3,  4,
25305      &    2,  3,  4,   1,  1,  4,   0,  0,  0,
25306      &    2,  2,  4,   0,  0,  0,   0,  0,  0,
25307      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25308      &    3,  4,  4,   7,  8, 10,   7,  9, 10 /
25309       DATA ((ITAB(I,K),I=1,3),K=151,180) /
25310      &    8,  9, 10,   7,  7, 10,   0,  0,  0,
25311      &    8,  8, 10,   0,  0,  0,   0,  0,  0,
25312      &    9,  9, 10,   7, 10, 10,   8, 10, 10,
25313      &    9, 10, 10,   1,  1,  4,   1,  2,  4,
25314      &    2,  2,  4,   1,  3,  4,   2,  3,  4,
25315      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25316      &    3,  4,  4,   4,  4,  4,   7,  7, 10,
25317      &    7,  8, 10,   8,  8, 10,   7,  9, 10,
25318      &    8,  9, 10,   9,  9, 10,   7, 10, 10,
25319      &    8, 10, 10,   9, 10, 10,  10, 10, 10 /
25320       DATA ((ITAB(I,K),I=1,3),K=181,210) /
25321      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25322      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25323      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25324      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25325      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25326      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25327      &    0,  0,  0,   0,  0,  0,   1,  7,  0,
25328      &    2,  8,  0,   1,  7,  0,   2,  8,  0,
25329      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25330      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25331       DATA IDOLD /0/
25332
25333       ONE = 1.0D0
25334       IF (ITAB(1,IDBAMJ).LE.200) THEN
25335          ID = ITAB(K,IDBAMJ)
25336       ELSE
25337          IF(IDOLD.NE.IDBAMJ) THEN
25338             IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25339      &           DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25340         ELSE
25341            IDOLD = 0
25342         ENDIF
25343         ID = ITAB(K,IT)
25344       ENDIF
25345       IDOLD  = IDBAMJ
25346       IDT_IBJQUA = ID
25347
25348       RETURN
25349       END
25350
25351 *$ CREATE IDT_ICIHAD.FOR
25352 *COPY IDT_ICIHAD
25353 *
25354 *===icihad=============================================================*
25355 *
25356       INTEGER FUNCTION IDT_ICIHAD(MCIND)
25357
25358 ************************************************************************
25359 * Conversion of particle index PDG proposal --> BAMJET-index scheme    *
25360 * This is a completely new version dated 25.10.95.                     *
25361 * Renamed to be not in conflict with the modified PHOJET-version       *
25362 ************************************************************************
25363
25364       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25365       SAVE
25366
25367 * hadron index conversion (BAMJET <--> PDG)
25368       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25369      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25370      &                IAMCIN(210)
25371
25372       IDT_ICIHAD = 0
25373       KPDG   = ABS(MCIND)
25374       IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25375       IF (MCIND.LT.0) THEN
25376          JSIGN = 1
25377       ELSE
25378          JSIGN = 2
25379       ENDIF
25380       IF (KPDG.GE.10000) THEN
25381          DO 1 I=1,19
25382             IDT_ICIHAD = IBAM5(JSIGN,I)
25383             IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25384             IDT_ICIHAD = 0
25385     1    CONTINUE
25386       ELSEIF (KPDG.GE.1000) THEN
25387          DO 2 I=1,29
25388             IDT_ICIHAD = IBAM4(JSIGN,I)
25389             IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25390             IDT_ICIHAD = 0
25391     2    CONTINUE
25392       ELSEIF (KPDG.GE.100) THEN
25393          DO 3 I=1,22
25394             IDT_ICIHAD = IBAM3(JSIGN,I)
25395             IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25396             IDT_ICIHAD = 0
25397     3    CONTINUE
25398       ELSEIF (KPDG.GE.10) THEN
25399          DO 4 I=1,7
25400             IDT_ICIHAD = IBAM2(JSIGN,I)
25401             IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25402             IDT_ICIHAD = 0
25403     4    CONTINUE
25404       ENDIF
25405     5 CONTINUE
25406
25407       RETURN
25408       END
25409
25410 *$ CREATE IDT_IPDGHA.FOR
25411 *COPY IDT_IPDGHA
25412 *
25413 *===ipdgha=============================================================*
25414 *
25415       INTEGER FUNCTION IDT_IPDGHA(MCIND)
25416
25417 ************************************************************************
25418 * Conversion of particle index BAMJET-index scheme --> PDG proposal    *
25419 * Adopted from the original by S. Roesler. This version dated 12.5.95  *
25420 * Renamed to be not in conflict with the modified PHOJET-version       *
25421 ************************************************************************
25422
25423       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25424       SAVE
25425
25426 * hadron index conversion (BAMJET <--> PDG)
25427       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25428      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25429      &                IAMCIN(210)
25430
25431       IDT_IPDGHA = IAMCIN(MCIND)
25432
25433       RETURN
25434       END
25435
25436 *$ CREATE DT_FLAHAD.FOR
25437 *COPY DT_FLAHAD
25438 *
25439 *===flahad=============================================================*
25440 *
25441       SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25442
25443 ************************************************************************
25444 * sampling of FLAvor composition for HADrons/photons                   *
25445 *              ID         BAMJET-id of hadron                          *
25446 *              IF1,2,3    flavor content                               *
25447 *                         (u,d,s: 1,2,3;  au,ad,as: -1,-1,-3)          *
25448 * Note:  -  u,d numbering as in BAMJET                                 *
25449 *        -  ID .le. 30 !!                                              *
25450 * This version dated 12.03.96 is written by S. Roesler                 *
25451 ************************************************************************
25452
25453       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25454       SAVE
25455
25456 * auxiliary common for reggeon exchange (DTUNUC 1.x)
25457       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25458      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25459      &                IQTCHR(-6:6),MQUARK(3,39)
25460
25461       DIMENSION JSEL(3,6)
25462       DATA JSEL/ 1,2,3,  2,3,1,  3,1,2,  1,3,2,   2,1,3,   3,2,1/
25463
25464       ONE = 1.0D0
25465       IF (ID.EQ.7) THEN
25466 * photon (charge dependent flavour sampling)
25467          K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25468          IF (K.LE.4) THEN
25469             IF1 = 2
25470             IF2 = -2
25471          ELSE IF(K.EQ.5) THEN
25472             IF1 = 1
25473             IF2 = -1
25474          ELSE
25475             IF1 = 3
25476             IF2 = -3
25477          ENDIF
25478          IF(DT_RNDM(ONE).LT.0.5D0) THEN
25479             K   = IF1
25480             IF1 = IF2
25481             IF2 = K
25482          ENDIF
25483          IF3 = 0
25484       ELSE
25485 * hadron
25486          IX  = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25487          IF1 = MQUARK(JSEL(1,IX),ID)
25488          IF2 = MQUARK(JSEL(2,IX),ID)
25489          IF3 = MQUARK(JSEL(3,IX),ID)
25490          IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25491             IF1 = IF3
25492             IF3 = 0
25493          ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25494             IF2 = IF3
25495             IF3 = 0
25496          ENDIF
25497       ENDIF
25498
25499       RETURN
25500       END
25501
25502 *$ CREATE IDT_MCHAD.FOR
25503 *COPY IDT_MCHAD
25504 *
25505 *===mchad==============================================================*
25506 *
25507       INTEGER FUNCTION IDT_MCHAD(ITDTU)
25508
25509 ************************************************************************
25510 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25511 * Adopted from the original by S. Roesler. This version dated 6.5.95   *
25512 *                                                                      *
25513 * Last change 28.12.2006 by S. Roesler.                                *
25514 ************************************************************************
25515
25516       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25517       SAVE
25518
25519       DIMENSION ITRANS(210)
25520       DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25521      &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25522      &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25523      &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25524      &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25525      &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25526      &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25527
25528       IF ( ITDTU .GT. 0 ) THEN
25529          IDT_MCHAD = ITRANS(ITDTU)
25530       ELSE
25531          IDT_MCHAD = -1
25532       END IF
25533
25534       RETURN
25535       END
25536
25537 ************************************************************************
25538 *                                                                      *
25539 *   3) Energy-momentum and quantum number conservation check routines  *
25540 *                                                                      *
25541 ************************************************************************
25542 *$ CREATE DT_EMC1.FOR
25543 *COPY DT_EMC1
25544 *
25545 *===emc1===============================================================*
25546 *
25547       SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25548
25549 ************************************************************************
25550 * This version dated 15.12.94 is written by S. Roesler                 *
25551 ************************************************************************
25552
25553       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25554       SAVE
25555
25556       PARAMETER ( LINP = 10 ,
25557      &            LOUT = 6 ,
25558      &            LDAT = 9 )
25559
25560       PARAMETER (TINY10=1.0D-10)
25561
25562       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25563
25564       IREJ = 0
25565
25566       IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25567      &   WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25568
25569       IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25570          IF (MODE.EQ.1) THEN
25571             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25572          ELSEIF (MODE.EQ.2) THEN
25573             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25574          ENDIF
25575          CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25576          CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25577          CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25578       ELSEIF (MODE.LT.0) THEN
25579          IF (MODE.EQ.-1) THEN
25580             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25581          ELSEIF (MODE.EQ.-2) THEN
25582             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25583          ENDIF
25584          CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25585          CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25586          CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25587       ENDIF
25588
25589       IF (ABS(MODE).EQ.3) THEN
25590          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25591          IF (IREJ1.NE.0) GOTO 9999
25592       ENDIF
25593       RETURN
25594
25595  9999 CONTINUE
25596       IREJ = 1
25597       RETURN
25598       END
25599
25600 *$ CREATE DT_EMC2.FOR
25601 *COPY DT_EMC2
25602 *
25603 *===emc2===============================================================*
25604 *
25605       SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25606      &                                                MODE,IPOS,IREJ)
25607
25608 ************************************************************************
25609 *             MODE = 1   energy-momentum cons. check                   *
25610 *                  = 2   flavor-cons. check                            *
25611 *                  = 3   energy-momentum & flavor cons. check          *
25612 *                  = 4   energy-momentum & charge cons. check          *
25613 *                  = 5   energy-momentum & flavor & charge cons. check *
25614 * This version dated 16.01.95 is written by S. Roesler                 *
25615 ************************************************************************
25616
25617       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25618       SAVE
25619
25620       PARAMETER ( LINP = 10 ,
25621      &            LOUT = 6 ,
25622      &            LDAT = 9 )
25623
25624       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25625
25626 * event history
25627
25628       PARAMETER (NMXHKK=200000)
25629
25630       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25631      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25632      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25633
25634 * extended event history
25635       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25636      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25637      &                IHIST(2,NMXHKK)
25638
25639       IREJ  = 0
25640       IREJ1 = 0
25641       IREJ2 = 0
25642       IREJ3 = 0
25643
25644       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25645      &                CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25646       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25647      &                                CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25648       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25649       DO 1 I=1,NHKK
25650          IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25651      &       (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25652      &       (ISTHKK(I).EQ.IP5))                          THEN
25653             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25654      &                                    .OR.(MODE.EQ.5))
25655      &      CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25656      &                                               2,IDUM,IDUM)
25657             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25658      &         CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25659             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25660      &                            CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25661          ENDIF
25662          IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25663      &       (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25664      &       (ISTHKK(I).EQ.IN5))                          THEN
25665             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25666      &                                    .OR.(MODE.EQ.5))
25667      &      CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25668      &                                                   2,IDUM,IDUM)
25669             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25670      &         CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25671             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25672      &                            CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25673          ENDIF
25674     1 CONTINUE
25675       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25676      &   CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25677       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25678      &   CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25679       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25680       IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25681
25682       RETURN
25683
25684  9999 CONTINUE
25685       IREJ = 1
25686       RETURN
25687       END
25688
25689 *$ CREATE DT_EVTEMC.FOR
25690 *COPY DT_EVTEMC
25691 *
25692 *===evtemc=============================================================*
25693 *
25694       SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
25695
25696 ************************************************************************
25697 * This version dated 13.12.94 is written by S. Roesler                 *
25698 ************************************************************************
25699
25700       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25701       SAVE
25702
25703       PARAMETER ( LINP = 10 ,
25704      &            LOUT = 6 ,
25705      &            LDAT = 9 )
25706
25707       PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
25708      &           ZERO=0.0D0)
25709
25710 * event history
25711
25712       PARAMETER (NMXHKK=200000)
25713
25714       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25715      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25716      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25717
25718 * flags for input different options
25719       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
25720       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
25721      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
25722
25723       IREJ = 0
25724
25725       MODE = IMODE
25726       CHKLEV = TINY10
25727       IF (MODE.EQ.4) THEN
25728          CHKLEV = TINY2
25729          MODE   = 3
25730       ELSEIF (MODE.EQ.5) THEN
25731          CHKLEV = TINY1
25732          MODE   = 3
25733       ELSEIF (MODE.EQ.-1) THEN
25734          CHKLEV = EIO
25735          MODE   = 3
25736       ENDIF
25737
25738       IF (ABS(MODE).EQ.3) THEN
25739          PXDEV = PX
25740          PYDEV = PY
25741          PZDEV = PZ
25742          EDEV  = E
25743          IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
25744          IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
25745      &       (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
25746             IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
25747      &         'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
25748      &         '  event  ',NEVHKK,
25749      &         ' ! ',PXDEV,PYDEV,PZDEV,EDEV
25750             PX   = 0.0D0
25751             PY   = 0.0D0
25752             PZ   = 0.0D0
25753             E    = 0.0D0
25754             GOTO 9999
25755          ENDIF
25756          PX   = 0.0D0
25757          PY   = 0.0D0
25758          PZ   = 0.0D0
25759          E    = 0.0D0
25760          RETURN
25761       ENDIF
25762
25763       IF (MODE.EQ.1) THEN
25764          PX = 0.0D0
25765          PY = 0.0D0
25766          PZ = 0.0D0
25767          E  = 0.0D0
25768       ENDIF
25769
25770       PX = PX+PXIO
25771       PY = PY+PYIO
25772       PZ = PZ+PZIO
25773       E  = E+EIO
25774
25775       RETURN
25776
25777  9999 CONTINUE
25778       IREJ = 1
25779       RETURN
25780       END
25781
25782 *$ CREATE DT_EVTFLC.FOR
25783 *COPY DT_EVTFLC
25784 *
25785 *===evtflc=============================================================*
25786 *
25787       SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
25788
25789 ************************************************************************
25790 * Flavor conservation check.                                           *
25791 *        ID       identity of particle                                 *
25792 *        ID1 = 1  ID for q,aq,qq,aqaq in PDG-numbering scheme          *
25793 *            = 2  ID for particle/resonance in BAMJET numbering scheme *
25794 *            = 3  ID for particle/resonance in PDG    numbering scheme *
25795 *        MODE = 1 initialization and add ID                            *
25796 *             =-1 initialization and subtract ID                       *
25797 *             = 2 add ID                                               *
25798 *             =-2 subtract ID                                          *
25799 *             = 3 check flavor cons.                                   *
25800 *        IPOS     flag to give position of call of EVTFLC to output    *
25801 *                 unit in case of violation                            *
25802 * This version dated 10.01.95 is written by S. Roesler                 *
25803 ************************************************************************
25804
25805       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25806       SAVE
25807
25808       PARAMETER ( LINP = 10 ,
25809      &            LOUT = 6 ,
25810      &            LDAT = 9 )
25811
25812       PARAMETER (TINY10=1.0D-10)
25813
25814       IREJ = 0
25815
25816       IF (MODE.EQ.3) THEN
25817          IF (IFL.NE.0) THEN
25818             WRITE(LOUT,'(1X,A,I3,A,I3)')
25819      &         'EVTFLC: flavor-conservation failure at pos. ',IPOS,
25820      &         ' !  IFL = ',IFL
25821             IFL = 0
25822             GOTO 9999
25823          ENDIF
25824          IFL = 0
25825          RETURN
25826       ENDIF
25827
25828       IF (MODE.EQ.1) IFL = 0
25829       IF (ID.EQ.0)   RETURN
25830
25831       IF (ID1.EQ.1) THEN
25832          IDD = ABS(ID)
25833          NQ  = 1
25834          IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
25835          IF (IDD.GE.1000) NQ = 3
25836          DO 1 I=1,NQ
25837             IFBAM = IDT_IPDG2B(ID,I,2)
25838             IF (ABS(IFBAM).EQ.1) THEN
25839                IFBAM = SIGN(2,IFBAM)
25840             ELSEIF (ABS(IFBAM).EQ.2) THEN
25841                IFBAM = SIGN(1,IFBAM)
25842             ENDIF
25843             IF (MODE.GT.0) THEN
25844                IFL = IFL+IFBAM
25845             ELSE
25846                IFL = IFL-IFBAM
25847             ENDIF
25848     1    CONTINUE
25849          RETURN
25850       ENDIF
25851
25852       IDD = ID
25853       IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
25854       IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
25855          DO 2 I=1,3
25856             IF (MODE.GT.0) THEN
25857                IFL = IFL+IDT_IQUARK(I,IDD)
25858             ELSE
25859                IFL = IFL-IDT_IQUARK(I,IDD)
25860             ENDIF
25861     2    CONTINUE
25862       ENDIF
25863       RETURN
25864
25865  9999 CONTINUE
25866       IREJ = 1
25867       RETURN
25868       END
25869
25870 *$ CREATE DT_EVTCHG.FOR
25871 *COPY DT_EVTCHG
25872 *
25873 *===evtchg=============================================================*
25874 *
25875       SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
25876
25877 ************************************************************************
25878 * Charge conservation check.                                           *
25879 *        ID       identity of particle (PDG-numbering scheme)          *
25880 *        MODE = 1 initialization                                       *
25881 *             =-2 subtract ID-charge                                   *
25882 *             = 2 add ID-charge                                        *
25883 *             = 3 check charge cons.                                   *
25884 *        IPOS     flag to give position of call of EVTCHG to output    *
25885 *                 unit in case of violation                            *
25886 * This version dated 10.01.95 is written by S. Roesler                 *
25887 * Last change: s.r. 21.01.01                                           *
25888 ************************************************************************
25889
25890       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25891       SAVE
25892
25893       PARAMETER ( LINP = 10 ,
25894      &            LOUT = 6 ,
25895      &            LDAT = 9 )
25896
25897 * event history
25898
25899       PARAMETER (NMXHKK=200000)
25900
25901       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25902      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25903      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25904
25905 * particle properties (BAMJET index convention)
25906       CHARACTER*8  ANAME
25907       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
25908      &                IICH(210),IIBAR(210),K1(210),K2(210)
25909
25910       IREJ = 0
25911
25912       IF (MODE.EQ.1) THEN
25913          ICH  = 0
25914          IBAR = 0
25915          RETURN
25916       ENDIF
25917
25918       IF (MODE.EQ.3) THEN
25919          IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
25920             WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
25921      &         'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
25922      &         '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
25923             ICH  = 0
25924             IBAR = 0
25925             GOTO 9999
25926          ENDIF
25927          ICH  = 0
25928          IBAR = 0
25929          RETURN
25930       ENDIF
25931
25932       IF (ID.EQ.0)   RETURN
25933
25934       IDD = IDT_ICIHAD(ID)
25935 * modification 21.1.01: use intrinsic phojet-functions to determine charge
25936 * and baryon number
25937 C     IF (IDD.GT.0) THEN
25938 C        IF (MODE.EQ.2) THEN
25939 C           ICH  = ICH+IICH(IDD)
25940 C           IBAR = IBAR+IIBAR(IDD)
25941 C        ELSEIF (MODE.EQ.-2) THEN
25942 C           ICH  = ICH-IICH(IDD)
25943 C           IBAR = IBAR-IIBAR(IDD)
25944 C        ENDIF
25945 C     ELSE
25946 C        WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
25947 C        CALL DT_EVTOUT(4)
25948 C        STOP
25949 C     ENDIF
25950       IF (MODE.EQ.2) THEN
25951          ICH  = ICH+IPHO_CHR3(ID,1)/3
25952          IBAR = IBAR+IPHO_BAR3(ID,1)/3
25953       ELSEIF (MODE.EQ.-2) THEN
25954          ICH  = ICH-IPHO_CHR3(ID,1)/3
25955          IBAR = IBAR-IPHO_BAR3(ID,1)/3
25956       ENDIF
25957
25958       RETURN
25959
25960  9999 CONTINUE
25961       IREJ = 1
25962       RETURN
25963       END
25964
25965 ************************************************************************
25966 *                                                                      *
25967 *                 4) Transformations                                   *
25968 *                                                                      *
25969 ************************************************************************
25970 *$ CREATE DT_LTINI.FOR
25971 *COPY DT_LTINI
25972 *
25973 *===ltini==============================================================*
25974 *
25975       SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
25976
25977 ************************************************************************
25978 * Initializations of Lorentz-transformations, calculation of Lorentz-  *
25979 * parameters.                                                          *
25980 * This version dated 13.11.95 is written by  S. Roesler.               *
25981 ************************************************************************
25982
25983       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25984       SAVE
25985
25986       PARAMETER ( LINP = 10 ,
25987      &            LOUT = 6 ,
25988      &            LDAT = 9 )
25989
25990       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
25991      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
25992
25993 * Lorentz-parameters of the current interaction
25994       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
25995      &                UMO,PPCM,EPROJ,PPROJ
25996
25997 * properties of photon/lepton projectiles
25998       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
25999
26000 * particle properties (BAMJET index convention)
26001       CHARACTER*8  ANAME
26002       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26003      &                IICH(210),IIBAR(210),K1(210),K2(210)
26004
26005 * nucleon-nucleon event-generator
26006       CHARACTER*8 CMODEL
26007       LOGICAL LPHOIN
26008       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26009
26010       Q2   = VIRT
26011       IDP  = IDPR
26012       IF (MCGENE.NE.3) THEN
26013 * lepton-projectiles and PHOJET: initialize real photon instead
26014          IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26015      &       (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26016      &       (IDPR.EQ. 5).OR.(IDPR.EQ. 6))   THEN
26017             IDP = 7
26018             Q2  = ZERO
26019          ENDIF
26020       ENDIF
26021       IDT  = IDTA
26022       EPN  = EPN0
26023       PPN  = PPN0
26024       ECM  = ECM0
26025       AMP  = AAM(IDP)-SQRT(ABS(Q2))
26026       AMT  = AAM(IDT)
26027       AMP2 = SIGN(AMP**2,AMP)
26028       AMT2 = AMT**2
26029       IF (ECM0.GT.ZERO) THEN
26030          EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26031          IF (AMP2.GT.ZERO) THEN
26032             PPN = SQRT((EPN+AMP)*(EPN-AMP))
26033          ELSE
26034             PPN = SQRT(EPN**2-AMP2)
26035          ENDIF
26036       ELSE
26037          IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26038             IF (IDP.EQ.7) EPN = ABS(EPN)
26039             IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26040             IF (AMP2.GT.ZERO) THEN
26041                PPN = SQRT((EPN+AMP)*(EPN-AMP))
26042             ELSE
26043                PPN = SQRT(EPN**2-AMP2)
26044             ENDIF
26045          ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26046             IF (AMP2.GT.ZERO) THEN
26047                EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26048             ELSE
26049                EPN = SQRT(PPN**2+AMP2)
26050             ENDIF
26051          ENDIF
26052          ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26053       ENDIF
26054       UMO   = ECM
26055       EPROJ = EPN
26056       PPROJ = PPN
26057       IF (AMP2.GT.ZERO) THEN
26058          ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26059          PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26060       ELSE
26061          ETARG = TINY10
26062          PTARG = TINY10
26063       ENDIF
26064 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26065       IF (IDP.EQ.7) THEN
26066          PGAMM(1) = ZERO
26067          PGAMM(2) = ZERO
26068          AMGAM  = AMP
26069          AMGAM2 = AMP2
26070          IF (ECM0.GT.ZERO) THEN
26071             S = ECM0**2
26072          ELSE
26073             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26074                S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26075             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26076                S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26077             ENDIF
26078          ENDIF
26079          PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26080      &                     +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26081          PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26082          IF (MODE.EQ.1) THEN
26083             PNUCL(1) = ZERO
26084             PNUCL(2) = ZERO
26085             PNUCL(3) = -PGAMM(3)
26086             PNUCL(4) = SQRT(S)-PGAMM(4)
26087          ENDIF
26088       ENDIF
26089       IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26090      &    (IDPR.EQ.10).OR.(IDPR.EQ.11))   THEN
26091          PLEPT0(1) = ZERO
26092          PLEPT0(2) = ZERO
26093 * neglect lepton masses
26094 C        AMLPT2   = AAM(IDPR)**2
26095          AMLPT2   = ZERO
26096 *
26097          IF (ECM0.GT.ZERO) THEN
26098             S = ECM0**2
26099          ELSE
26100             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26101                S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26102             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26103                S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26104             ENDIF
26105          ENDIF
26106          PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26107      &                     +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26108          PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26109          PNUCL(1) = ZERO
26110          PNUCL(2) = ZERO
26111          PNUCL(3) = -PLEPT0(3)
26112          PNUCL(4) = SQRT(S)-PLEPT0(4)
26113       ENDIF
26114 * Lorentz-parameter for transformation Lab. - projectile rest system
26115       IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26116          GALAB = TINY10
26117          BGLAB = TINY10
26118          BLAB  = TINY10
26119       ELSE
26120          GALAB = EPROJ/AMP
26121          BGLAB = PPROJ/AMP
26122          BLAB  = BGLAB/GALAB
26123       ENDIF
26124 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26125       IF (IDP.EQ.7) THEN
26126          GACMS(1) = TINY10
26127          BGCMS(1) = TINY10
26128       ELSE
26129          GACMS(1) = (ETARG+AMP)/UMO
26130          BGCMS(1) = PTARG/UMO
26131       ENDIF
26132 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26133       GACMS(2) = (EPROJ+AMT)/UMO
26134       BGCMS(2) = PPROJ/UMO
26135       PPCM     = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26136
26137       EPN0 = EPN
26138       PPN0 = PPN
26139       ECM0 = ECM
26140
26141       RETURN
26142       END
26143
26144 *$ CREATE DT_LTRANS.FOR
26145 *COPY DT_LTRANS
26146 *
26147 *===ltrans=============================================================*
26148 *
26149       SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26150
26151 ************************************************************************
26152 * Lorentz-transformations.                                             *
26153 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26154 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26155 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26156 * This version dated 01.11.95 is written by  S. Roesler.               *
26157 ************************************************************************
26158
26159       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26160       SAVE
26161
26162       PARAMETER ( LINP = 10 ,
26163      &            LOUT = 6 ,
26164      &            LDAT = 9 )
26165
26166       PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26167
26168       PARAMETER (SQTINF=1.0D+15)
26169
26170 * particle properties (BAMJET index convention)
26171       CHARACTER*8  ANAME
26172       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26173      &                IICH(210),IIBAR(210),K1(210),K2(210)
26174
26175       PXO = PXI
26176       PYO = PYI
26177       CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26178
26179 * check particle mass for consistency (numerical rounding errors)
26180       PO     = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26181       AMO2   = (PEO-PO)*(PEO+PO)
26182       AMORQ2 = AAM(ID)**2
26183       AMDIF2 = ABS(AMO2-AMORQ2)
26184       IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26185          DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26186          PEO   = PEO+DELTA
26187          PO1   = PO -DELTA
26188          PXO   = PXO*PO1/PO
26189          PYO   = PYO*PO1/PO
26190          PZO   = PZO*PO1/PO
26191 C        WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26192       ENDIF
26193
26194       RETURN
26195       END
26196
26197 *$ CREATE DT_LTNUC.FOR
26198 *COPY DT_LTNUC
26199 *
26200 *===ltnuc==============================================================*
26201 *
26202       SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26203
26204 ************************************************************************
26205 * Lorentz-transformations.                                             *
26206 *   PIN        longitudnal momentum       (input)                      *
26207 *   EIN        energy                     (input)                      *
26208 *   POUT       transformed long. momentum (output)                     *
26209 *   EOUT       transformed energy         (output)                     *
26210 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26211 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26212 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26213 * This version dated 01.11.95 is written by  S. Roesler.               *
26214 ************************************************************************
26215
26216       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26217       SAVE
26218
26219       PARAMETER ( LINP = 10 ,
26220      &            LOUT = 6 ,
26221      &            LDAT = 9 )
26222
26223       PARAMETER (ZERO=0.0D0)
26224
26225 * Lorentz-parameters of the current interaction
26226       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26227      &                UMO,PPCM,EPROJ,PPROJ
26228
26229       BDUM1 = ZERO
26230       BDUM2 = ZERO
26231       PDUM1 = ZERO
26232       PDUM2 = ZERO
26233       IF (ABS(MODE).EQ.1) THEN
26234          BG = -SIGN(BGLAB,DBLE(MODE))
26235          CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26236      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26237       ELSEIF (ABS(MODE).EQ.2) THEN
26238          BG = SIGN(BGCMS(1),DBLE(MODE))
26239          CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26240      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26241       ELSEIF (ABS(MODE).EQ.3) THEN
26242          BG = -SIGN(BGCMS(2),DBLE(MODE))
26243          CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26244      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26245       ELSE
26246          WRITE(LOUT,1000) MODE
26247  1000    FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26248          EOUT = EIN
26249          POUT = PIN
26250       ENDIF
26251
26252       RETURN
26253       END
26254
26255 *$ CREATE DT_DALTRA.FOR
26256 *COPY DT_DALTRA
26257 *
26258 *===daltra=============================================================*
26259 *
26260       SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26261
26262 ************************************************************************
26263 * Arbitrary Lorentz-transformation.                                    *
26264 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
26265 ************************************************************************
26266
26267       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26268       SAVE
26269       PARAMETER (ONE=1.0D0)
26270
26271       EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26272       PE = EP/(GA+ONE)+EC
26273       PX = PCX+BGX*PE
26274       PY = PCY+BGY*PE
26275       PZ = PCZ+BGZ*PE
26276       P  = SQRT(PX*PX+PY*PY+PZ*PZ)
26277       E  = GA*EC+EP
26278
26279       RETURN
26280       END
26281
26282 *$ CREATE DT_DTRAFO.FOR
26283 *COPY DT_DTRAFO
26284 *
26285 *====dtrafo============================================================*
26286 *
26287       SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26288      &                                    PL,CXL,CYL,CZL,EL)
26289
26290 C     LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26291
26292       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26293       SAVE
26294
26295       IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26296       SID  = SQRT(1.D0-COD*COD)
26297       PLX  = P*SID*COF
26298       PLY  = P*SID*SIF
26299       PCMZ = P*COD
26300       PLZ  = GAM*PCMZ+BGAM*ECM
26301       PL   = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26302       EL   = GAM*ECM+BGAM*PCMZ
26303 C     ROTATION INTO THE ORIGINAL DIRECTION
26304       COZ  = PLZ/PL
26305       SIZ  = SQRT(1.D0-COZ**2)
26306       CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26307
26308       RETURN
26309       END
26310
26311 *$ CREATE DT_STTRAN.FOR
26312 *COPY DT_STTRAN
26313 *
26314 *====sttran============================================================*
26315 *
26316       SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26317
26318       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26319       SAVE
26320       DATA ANGLSQ/1.D-30/
26321 ************************************************************************
26322 *     VERSION BY                     J. RANFT                          *
26323 *                                    LEIPZIG                           *
26324 *                                                                      *
26325 *     THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES      *
26326 *                                                                      *
26327 *     INPUT VARIABLES:                                                 *
26328 *        XO,YO,ZO = ORIGINAL DIRECTION COSINES                         *
26329 *        CDE,SDE  = COSINE AND SINE OF THE POLAR (THETA)               *
26330 *                   ANGLE OF "SCATTERING"                              *
26331 *        SDE      = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING"    *
26332 *        SFE,CFE  = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE       *
26333 *                   OF "SCATTERING"                                    *
26334 *                                                                      *
26335 *     OUTPUT VARIABLES:                                                *
26336 *        X,Y,Z     = NEW DIRECTION COSINES                             *
26337 *                                                                      *
26338 *     ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 )                  *
26339 ************************************************************************
26340 *
26341 *
26342 *  Changed by A. Ferrari
26343 *
26344 *     IF (ABS(XO)-0.0001D0) 1,1,2
26345 *   1 IF (ABS(YO)-0.0001D0) 3,3,2
26346 *   3 CONTINUE
26347       A = XO**2 + YO**2
26348       IF ( A .LT. ANGLSQ ) THEN
26349          X=SDE*CFE
26350          Y=SDE*SFE
26351          Z=CDE*ZO
26352       ELSE
26353          XI=SDE*CFE
26354          YI=SDE*SFE
26355          ZI=CDE
26356          A=SQRT(A)
26357          X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26358          Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26359          Z=A*YI+ZO*ZI
26360       ENDIF
26361
26362       RETURN
26363       END
26364
26365 *$ CREATE DT_MYTRAN.FOR
26366 *COPY DT_MYTRAN
26367 *
26368 *===mytran=============================================================*
26369 *
26370       SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26371
26372 ************************************************************************
26373 * This subroutine rotates the coordinate frame                         *
26374 *    a) theta  around y                                                *
26375 *    b) phi    around z      if IMODE = 1                              *
26376 *                                                                      *
26377 *     x'          cos(ph) -sin(ph) 0      cos(th)  0  sin(th)   x      *
26378 *     y' = A B =  sin(ph) cos(ph)  0  .   0        1        0   y      *
26379 *     z'          0       0        1     -sin(th)  0  cos(th)   z      *
26380 *                                                                      *
26381 * and vice versa if IMODE = 0.                                         *
26382 * This version dated 5.4.94 is based on the original version DTRAN     *
26383 * by J. Ranft and is written by S. Roesler.                            *
26384 ************************************************************************
26385
26386       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26387       SAVE
26388
26389       PARAMETER ( LINP = 10 ,
26390      &            LOUT = 6 ,
26391      &            LDAT = 9 )
26392
26393       IF (IMODE.EQ.1) THEN
26394          X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26395          Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26396          Z=-SDE    *XO       +CDE    *ZO
26397       ELSE
26398          X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26399          Y= -SFE*XO+CFE*YO
26400          Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26401       ENDIF
26402       RETURN
26403       END
26404
26405 *$ CREATE DT_LT2LAO.FOR
26406 *COPY DT_LT2LAO
26407 *
26408 *===lt2lab=============================================================*
26409 *
26410       SUBROUTINE DT_LT2LAO
26411
26412 ************************************************************************
26413 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26414 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26415 * and transforms them back to the lab.                                 *
26416 * This version dated 16.11.95 is written by S. Roesler                 *
26417 ************************************************************************
26418
26419       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26420       SAVE
26421
26422       PARAMETER ( LINP = 10 ,
26423      &            LOUT = 6 ,
26424      &            LDAT = 9 )
26425
26426 * event history
26427
26428       PARAMETER (NMXHKK=200000)
26429
26430       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26431      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26432      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26433
26434 * extended event history
26435       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26436      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26437      &                IHIST(2,NMXHKK)
26438
26439       NEND      = NHKK
26440       NPOINT(5) = NHKK+1
26441       IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26442       DO 1 I=NPOINT(4),NEND
26443 C     DO 1 I=1,NEND
26444          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26445      &                                (ISTHKK(I).EQ.1001)) THEN
26446             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26447             NOB = NOBAM(I)
26448             CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26449      &                            PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26450             IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26451                ISTHKK(I) = 3*ISTHKK(I)
26452                NOBAM(NHKK)  = NOB
26453             ELSE
26454                IF (ISTHKK(I).EQ.-1) NOBAM(NHKK)  = NOB
26455                ISTHKK(I) = SIGN(3,ISTHKK(I))
26456             ENDIF
26457             JDAHKK(1,I) = NHKK
26458          ENDIF
26459     1 CONTINUE
26460
26461       RETURN
26462       END
26463
26464 *$ CREATE DT_LT2LAB.FOR
26465 *COPY DT_LT2LAB
26466 *
26467 *===lt2lab=============================================================*
26468 *
26469       SUBROUTINE DT_LT2LAB
26470
26471 ************************************************************************
26472 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26473 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26474 * and transforms them to the lab.                                      *
26475 * This version dated 07.01.96 is written by S. Roesler                 *
26476 ************************************************************************
26477
26478       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26479       SAVE
26480
26481       PARAMETER ( LINP = 10 ,
26482      &            LOUT = 6 ,
26483      &            LDAT = 9 )
26484
26485 * event history
26486
26487       PARAMETER (NMXHKK=200000)
26488
26489       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26490      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26491      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26492
26493 * extended event history
26494       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26495      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26496      &                IHIST(2,NMXHKK)
26497
26498       IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26499       DO 1 I=NPOINT(4),NHKK
26500          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26501      &                                (ISTHKK(I).EQ.1001)) THEN
26502             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26503             PHKK(3,I) = PZ
26504             PHKK(4,I) = PE
26505          ENDIF
26506     1 CONTINUE
26507
26508       RETURN
26509       END
26510
26511 ************************************************************************
26512 *                                                                      *
26513 *                 5) Sampling from distributions                       *
26514 *                                                                      *
26515 ************************************************************************
26516 *$ CREATE IDT_NPOISS.FOR
26517 *COPY IDT_NPOISS
26518 *
26519 *===npoiss=============================================================*
26520 *
26521       INTEGER FUNCTION IDT_NPOISS(AVN)
26522
26523 ************************************************************************
26524 * Sample according to Poisson distribution with Poisson parameter AVN. *
26525 * The original version written by J. Ranft.                            *
26526 * This version dated 11.1.95 is written by S. Roesler.                 *
26527 ************************************************************************
26528
26529       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26530       SAVE
26531
26532       PARAMETER ( LINP = 10 ,
26533      &            LOUT = 6 ,
26534      &            LDAT = 9 )
26535
26536       EXPAVN = EXP(-AVN)
26537       K = 1
26538       A = 1.0D0
26539
26540    10 CONTINUE
26541       A = DT_RNDM(A)*A
26542       IF (A.GE.EXPAVN) THEN
26543          K = K+1
26544          GOTO 10
26545       ENDIF
26546       IDT_NPOISS = K-1
26547
26548       RETURN
26549       END
26550
26551 *$ CREATE DT_SAMPXB.FOR
26552 *COPY DT_SAMPXB
26553 *
26554 *===sampxb=============================================================*
26555 *
26556       DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26557
26558 ************************************************************************
26559 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2.             *
26560 * Processed by S. Roesler, 6.5.95                                      *
26561 ************************************************************************
26562
26563       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26564       SAVE
26565       PARAMETER (TWO=2.0D0)
26566
26567       A1 = LOG(X1+SQRT(X1**2+B**2))
26568       A2 = LOG(X2+SQRT(X2**2+B**2))
26569       AN = A2-A1
26570       A  = AN*DT_RNDM(A1)+A1
26571       BB = EXP(A)
26572       DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26573
26574       RETURN
26575       END
26576
26577 *$ CREATE DT_SAMPEX.FOR
26578 *COPY DT_SAMPEX
26579 *
26580 *===sampex=============================================================*
26581 *
26582       DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26583
26584 ************************************************************************
26585 * Sampling from f(x)=1./x between x1 and x2.                           *
26586 * Processed by S. Roesler, 6.5.95                                      *
26587 ************************************************************************
26588
26589       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26590       SAVE
26591       PARAMETER (ONE=1.0D0)
26592
26593       R   = DT_RNDM(X1)
26594       AL1 = LOG(X1)
26595       AL2 = LOG(X2)
26596       DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26597
26598       RETURN
26599       END
26600
26601 *$ CREATE DT_SAMSQX.FOR
26602 *COPY DT_SAMSQX
26603 *
26604 *===samsqx=============================================================*
26605 *
26606       DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26607
26608 ************************************************************************
26609 * Sampling from f(x)=1./x^0.5 between x1 and x2.                       *
26610 * Processed by S. Roesler, 6.5.95                                      *
26611 ************************************************************************
26612
26613       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26614       SAVE
26615       PARAMETER (ONE=1.0D0)
26616
26617       R = DT_RNDM(X1)
26618       DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26619
26620       RETURN
26621       END
26622
26623 *$ CREATE DT_SAMPLW.FOR
26624 *COPY DT_SAMPLW
26625 *
26626 *===samplw=============================================================*
26627 *
26628       DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26629
26630 ************************************************************************
26631 * Sampling from f(x)=1/x^b between x_min and x_max.                    *
26632 * S. Roesler, 18.4.98                                                  *
26633 ************************************************************************
26634
26635       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26636       SAVE
26637       PARAMETER (ONE=1.0D0)
26638
26639       R = DT_RNDM(B)
26640       IF (B.EQ.ONE) THEN
26641          DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26642       ELSE
26643          ONEMB  = ONE-B
26644          DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26645       ENDIF
26646
26647       RETURN
26648       END
26649
26650 *$ CREATE DT_BETREJ.FOR
26651 *COPY DT_BETREJ
26652 *
26653 *===betrej=============================================================*
26654 *
26655       DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26656
26657       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26658       SAVE
26659
26660       PARAMETER ( LINP = 10 ,
26661      &            LOUT = 6 ,
26662      &            LDAT = 9 )
26663
26664       PARAMETER (ONE=1.0D0)
26665
26666       IF (XMIN.GE.XMAX)THEN
26667          WRITE (LOUT,500) XMIN,XMAX
26668   500    FORMAT(1X,'DT_BETREJ:  XMIN<XMAX execution stopped ',2F10.5)
26669          STOP
26670       ENDIF
26671
26672    10 CONTINUE
26673       XX     = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26674       BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26675       YY     = BETMAX*DT_RNDM(XX)
26676       BETXX  = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26677       IF (YY.GT.BETXX) GOTO 10
26678       DT_BETREJ = XX
26679
26680       RETURN
26681       END
26682
26683 *$ CREATE DT_DGAMRN.FOR
26684 *COPY DT_DGAMRN
26685 *
26686 *===dgamrn=============================================================*
26687 *
26688       DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26689
26690 ************************************************************************
26691 * Sampling from Gamma-distribution.                                    *
26692 *       F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)            *
26693 * Processed by S. Roesler, 6.5.95                                      *
26694 ************************************************************************
26695
26696       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26697       SAVE
26698       PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26699
26700       NCOU = 0
26701       N    = INT(ETA)
26702       F    = ETA-DBLE(N)
26703       IF (F.EQ.ZERO) GOTO 20
26704    10 R = DT_RNDM(F)
26705       NCOU = NCOU+1
26706       IF (NCOU.GE.11) GOTO 20
26707       IF (R.LT.F/(F+2.71828D0)) GOTO 30
26708       YYY = LOG(DT_RNDM(R)+TINY9)/F
26709       IF (ABS(YYY).GT.50.0D0) GOTO 20
26710       Y = EXP(YYY)
26711       IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26712       GOTO 40
26713    20 Y = 0.0D0
26714       GOTO 50
26715    30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26716       IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
26717    40 IF (N.EQ.0) GOTO 70
26718    50 Z = 1.0D0
26719       DO 60 I = 1,N
26720    60 Z = Z*DT_RNDM(Z)
26721       Y = Y-LOG(Z+TINY9)
26722    70 DT_DGAMRN = Y/ALAM
26723
26724       RETURN
26725       END
26726
26727 *$ CREATE DT_DBETAR.FOR
26728 *COPY DT_DBETAR
26729 *
26730 *===dbetar=============================================================*
26731 *
26732       DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
26733
26734 ************************************************************************
26735 * Sampling from Beta -distribution between 0.0 and 1.0                 *
26736 *  F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
26737 * Processed by S. Roesler, 6.5.95                                      *
26738 ************************************************************************
26739
26740       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26741       SAVE
26742
26743       Y = DT_DGAMRN(1.0D0,GAM)
26744       Z = DT_DGAMRN(1.0D0,ETA)
26745       DT_DBETAR = Y/(Y+Z)
26746
26747       RETURN
26748       END
26749
26750 *$ CREATE DT_RANNOR.FOR
26751 *COPY DT_RANNOR
26752 *
26753 *===rannor=============================================================*
26754 *
26755       SUBROUTINE DT_RANNOR(X,Y)
26756
26757 ************************************************************************
26758 * Sampling from Gaussian distribution.                                 *
26759 * Processed by S. Roesler, 6.5.95                                      *
26760 ************************************************************************
26761
26762       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26763       SAVE
26764       PARAMETER (TINY10=1.0D-10)
26765
26766       CALL DT_DSFECF(SFE,CFE)
26767       V = MAX(TINY10,DT_RNDM(X))
26768       A = SQRT(-2.D0*LOG(V))
26769       X = A*SFE
26770       Y = A*CFE
26771
26772       RETURN
26773       END
26774
26775 *$ CREATE DT_DPOLI.FOR
26776 *COPY DT_DPOLI
26777 *
26778 *===dpoli==============================================================*
26779 *
26780       SUBROUTINE DT_DPOLI(CS,SI)
26781
26782       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26783       SAVE
26784
26785       U  = DT_RNDM(CS)
26786       CS = DT_RNDM(U)
26787       IF (U.LT.0.5D0) CS=-CS
26788       SI = SQRT(1.0D0-CS*CS+1.0D-10)
26789
26790       RETURN
26791       END
26792
26793 *$ CREATE DT_DSFECF.FOR
26794 *COPY DT_DSFECF
26795 *
26796 *===dsfecf=============================================================*
26797 *
26798       SUBROUTINE DT_DSFECF(SFE,CFE)
26799
26800       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26801       SAVE
26802       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26803
26804     1 CONTINUE
26805       X  = DT_RNDM(SFE)
26806       Y  = DT_RNDM(X)
26807       XX = X*X
26808       YY = Y*Y
26809       XY = XX+YY
26810       IF (XY.GT.ONE) GOTO 1
26811       CFE = (XX-YY)/XY
26812       SFE = TWO*X*Y/XY
26813       IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
26814       RETURN
26815       END
26816
26817 *$ CREATE DT_RACO.FOR
26818 *COPY DT_RACO
26819 *
26820 *===raco===============================================================*
26821 *
26822       SUBROUTINE DT_RACO(WX,WY,WZ)
26823
26824 ************************************************************************
26825 * Direction cosines of random uniform (isotropic) direction in three   *
26826 * dimensional space                                                    *
26827 * Processed by S. Roesler, 20.11.95                                    *
26828 ************************************************************************
26829
26830       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26831       SAVE
26832       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26833
26834   10  CONTINUE
26835       X  = TWO*DT_RNDM(WX)-ONE
26836       Y  = DT_RNDM(X)
26837       X2 = X*X
26838       Y2 = Y*Y
26839       IF (X2+Y2.GT.ONE) GOTO 10
26840
26841       CFE = (X2-Y2)/(X2+Y2)
26842       SFE = TWO*X*Y/(X2+Y2)
26843 * z = 1/2 [ 1 + cos (theta) ]
26844       Z   = DT_RNDM(X)
26845 * 1/2 sin (theta)
26846       WZ = SQRT(Z*(ONE-Z))
26847       WX = TWO*WZ*CFE
26848       WY = TWO*WZ*SFE
26849       WZ = TWO*Z-ONE
26850
26851       RETURN
26852       END
26853
26854 ************************************************************************
26855 *                                                                      *
26856 *           6) Special functions, algorithms and service routines      *
26857 *                                                                      *
26858 ************************************************************************
26859 *$ CREATE DT_YLAMB.FOR
26860 *COPY DT_YLAMB
26861 *
26862 *===ylamb==============================================================*
26863 *
26864       DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
26865
26866 ************************************************************************
26867 *                                                                      *
26868 *     auxiliary function for three particle decay mode                 *
26869 *     (standard LAMBDA**(1/2) function)                                *
26870 *                                                                      *
26871 * Adopted from an original version written by R. Engel.                *
26872 * This version dated 12.12.94 is written by S. Roesler.                *
26873 ************************************************************************
26874
26875       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26876       SAVE
26877
26878       YZ   = Y-Z
26879       XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
26880       IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
26881       DT_YLAMB = SQRT(XLAM)
26882
26883       RETURN
26884       END
26885
26886 *$ CREATE DT_SORT.FOR
26887 *COPY DT_SORT
26888 *
26889 *===sort1==============================================================*
26890 *
26891       SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
26892
26893 ************************************************************************
26894 * This subroutine sorts entries in A in increasing/decreasing order    *
26895 * of A(3,i).                                                           *
26896 *              MODE  = 1     increasing in A(3,i=1..N)                 *
26897 *                    = 2     decreasing in A(3,i=1..N)                 *
26898 * This version dated 21.04.95 is revised by S. Roesler                 *
26899 ************************************************************************
26900
26901       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26902       SAVE
26903
26904       DIMENSION A(3,N)
26905
26906       M = I1
26907    10 CONTINUE
26908       M = I1-1
26909       IF (M.LE.0) RETURN
26910       L = 0
26911       DO 20 I=I0,M
26912          J = I+1
26913          IF (MODE.EQ.1) THEN
26914             IF (A(3,I).LE.A(3,J)) GOTO 20
26915          ELSE
26916             IF (A(3,I).GE.A(3,J)) GOTO 20
26917          ENDIF
26918          B = A(3,I)
26919          C = A(1,I)
26920          D = A(2,I)
26921          A(3,I) = A(3,J)
26922          A(2,I) = A(2,J)
26923          A(1,I) = A(1,J)
26924          A(3,J) = B
26925          A(1,J) = C
26926          A(2,J) = D
26927          L = 1
26928    20 CONTINUE
26929       IF (L.EQ.1) GOTO 10
26930
26931       RETURN
26932       END
26933
26934 *$ CREATE DT_SORT1.FOR
26935 *COPY DT_SORT1
26936 *
26937 *===sort1==============================================================*
26938 *
26939       SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
26940
26941 ************************************************************************
26942 * This subroutine sorts entries in A in increasing/decreasing order    *
26943 * of A(i).                                                             *
26944 *              MODE  = 1     increasing in A(i=1..N)                   *
26945 *                    = 2     decreasing in A(i=1..N)                   *
26946 * This version dated 21.04.95 is revised by S. Roesler                 *
26947 ************************************************************************
26948
26949       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26950       SAVE
26951
26952       DIMENSION A(N),IDX(N)
26953
26954       M = I1
26955    10 CONTINUE
26956       M = I1-1
26957       IF (M.LE.0) RETURN
26958       L = 0
26959       DO 20 I=I0,M
26960          J = I+1
26961          IF (MODE.EQ.1) THEN
26962             IF (A(I).LE.A(J)) GOTO 20
26963          ELSE
26964             IF (A(I).GE.A(J)) GOTO 20
26965          ENDIF
26966          B    = A(I)
26967          A(I) = A(J)
26968          A(J) = B
26969          IX     = IDX(I)
26970          IDX(I) = IDX(J)
26971          IDX(J) = IX
26972          L = 1
26973    20 CONTINUE
26974       IF (L.EQ.1) GOTO 10
26975
26976       RETURN
26977       END
26978
26979 *$ CREATE DT_XTIME.FOR
26980 *COPY DT_XTIME
26981 *
26982 *===xtime==============================================================*
26983 *
26984       SUBROUTINE DT_XTIME
26985
26986       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26987       SAVE
26988
26989       PARAMETER ( LINP = 10 ,
26990      &            LOUT = 6 ,
26991      &            LDAT = 9 )
26992
26993       CHARACTER DAT*9,TIM*11
26994
26995       DAT = '         '
26996       TIM = '           '
26997 C     CALL GETDAT(IYEAR,IMONTH,IDAY)
26998 C     CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
26999
27000 C     CALL DATE(DAT)
27001 C     CALL TIME(TIM)
27002 C     WRITE(LOUT,1000) DAT,TIM
27003  1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27004
27005       RETURN
27006       END
27007
27008 ************************************************************************
27009 *                                                                      *
27010 *                 7) Random number generator package                   *
27011 *                                                                      *
27012 *    THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND        *
27013 *    SERVICE ROUTINES.                                                 *
27014 *    THE ALGORITHM IS FROM                                             *
27015 *      'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR'                     *
27016 *      G.MARSAGLIA, A.ZAMAN ;  FSU-SCRI-87-50                          *
27017 *    IMPLEMENTATION BY K. HAHN  DEC. 88,                               *
27018 *    THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27019 *    AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ),        *
27020 *    THE PERIOD IS ABOUT 2**144,                                       *
27021 *    TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS,            *
27022 *    THE PACKAGE CONTAINS                                              *
27023 *      FUNCTION DT_RNDM(I)                  : GENERATOR                *
27024 *      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION           *
27025 *      SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)  : PUT SEED TO GENERATOR    *
27026 *      SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)  : TAKE SEED FROM GENERATOR *
27027 *      SUBROUTINE DT_RNDMTE(IO)             : TEST OF GENERATOR        *
27028 *---                                                                   *
27029 *    FUNCTION DT_RNDM(I)                                               *
27030 *       GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS  IN (0..1)          *
27031 *       I  - DUMMY VARIABLE, NOT USED                                  *
27032 *    SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)                             *
27033 *       INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27034 *       NA1,NA2,NA3,NB1  - VALUES FOR INITIALIZING THE GENERATOR       *
27035 *                          NA? MUST BE IN 1..178 AND NOT ALL 1         *
27036 *                          12,34,56  ARE THE STANDARD VALUES           *
27037 *                          NB1 MUST BE IN 1..168                       *
27038 *                          78  IS THE STANDARD VALUE                   *
27039 *    SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)                               *
27040 *       PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS   *
27041 *       AS AFTER THE LAST DT_RNDMOU CALL )                             *
27042 *       U(97),C,CD,CM,I,J  - SEED VALUES AS TAKEN FROM DT_RNDMOU       *
27043 *    SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)                               *
27044 *       TAKES SEED FROM GENERATOR                                      *
27045 *       U(97),C,CD,CM,I,J  - SEED VALUES                               *
27046 *    SUBROUTINE DT_RNDMTE(IO)                                          *
27047 *       TEST OF THE GENERATOR                                          *
27048 *       IO     - DEFINES OUTPUT                                        *
27049 *                  = 0  OUTPUT ONLY IF AN ERROR IS DETECTED            *
27050 *                  = 1  OUTPUT INDEPENDEND ON AN ERROR                 *
27051 *       DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO   *
27052 *       SAME STATUS                                                    *
27053 *       AS BEFORE CALL OF DT_RNDMTE                                    *
27054 ************************************************************************
27055 *$ CREATE DT_RNDM.FOR
27056 *COPY DT_RNDM
27057 *
27058 *===rndm===============================================================*
27059 *
27060 c$$$      DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27061 c$$$
27062 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27063 c$$$      SAVE
27064 c$$$
27065 c$$$* counter of calls to random number generator
27066 c$$$* uncomment if needed
27067 c$$$C     COMMON /DTRNCT/ IRNCT0,IRNCT1
27068 c$$$C     LOGICAL LFIRST
27069 c$$$C     DATA LFIRST /.TRUE./
27070 c$$$
27071 c$$$* counter of calls to random number generator
27072 c$$$* uncomment if needed
27073 c$$$C     IF (LFIRST) THEN
27074 c$$$C        IRNCT0 = 0
27075 c$$$C        IRNCT1 = 0
27076 c$$$C        LFIRST = .FALSE.
27077 c$$$C     ENDIF
27078 c$$$
27079 c$$$      DT_RNDM = FLRNDM(VDUMMY)
27080 c$$$* counter of calls to random number generator
27081 c$$$* uncomment if needed
27082 c$$$C     IRNCT1 = IRNCT1+1
27083 c$$$
27084 c$$$      RETURN
27085 c$$$      END
27086 c$$$
27087 c$$$*$ CREATE DT_RNDMST.FOR
27088 c$$$*COPY DT_RNDMST
27089 c$$$*
27090 c$$$*===rndmst=============================================================*
27091 c$$$*
27092 c$$$      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27093 c$$$
27094 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27095 c$$$      SAVE
27096 c$$$
27097 c$$$* random number generator
27098 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27099 c$$$
27100 c$$$      MA1 = NA1
27101 c$$$      MA2 = NA2
27102 c$$$      MA3 = NA3
27103 c$$$      MB1 = NB1
27104 c$$$      I   = 97
27105 c$$$      J   = 33
27106 c$$$      DO 20 II2 = 1,97
27107 c$$$        S = 0
27108 c$$$        T = 0.5D0
27109 c$$$        DO 10 II1 = 1,24
27110 c$$$          MAT  = MOD(MOD(MA1*MA2,179)*MA3,179)
27111 c$$$          MA1  = MA2
27112 c$$$          MA2  = MA3
27113 c$$$          MA3  = MAT
27114 c$$$          MB1  = MOD(53*MB1+1,169)
27115 c$$$          IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27116 c$$$   10   T = 0.5D0*T
27117 c$$$   20 U(II2) = S
27118 c$$$      C  =   362436.0D0/16777216.0D0
27119 c$$$      CD =  7654321.0D0/16777216.0D0
27120 c$$$      CM = 16777213.0D0/16777216.0D0
27121 c$$$      RETURN
27122 c$$$      END
27123 c$$$
27124 c$$$*$ CREATE DT_RNDMIN.FOR
27125 c$$$*COPY DT_RNDMIN
27126 c$$$*
27127 c$$$*===rndmin=============================================================*
27128 c$$$*
27129 c$$$      SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27130 c$$$
27131 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27132 c$$$      SAVE
27133 c$$$
27134 c$$$* random number generator
27135 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27136 c$$$
27137 c$$$      DIMENSION UIN(97)
27138 c$$$
27139 c$$$      DO 10 KKK = 1,97
27140 c$$$   10 U(KKK) = UIN(KKK)
27141 c$$$      C  = CIN
27142 c$$$      CD = CDIN
27143 c$$$      CM = CMIN
27144 c$$$      I  = IIN
27145 c$$$      J  = JIN
27146 c$$$
27147 c$$$      RETURN
27148 c$$$      END
27149 c$$$
27150 c$$$*$ CREATE DT_RNDMOU.FOR
27151 c$$$*COPY DT_RNDMOU
27152 c$$$*
27153 c$$$*===rndmou=============================================================*
27154 c$$$*
27155 c$$$      SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27156 c$$$
27157 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27158 c$$$      SAVE
27159 c$$$
27160 c$$$* random number generator
27161 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27162 c$$$
27163 c$$$      DIMENSION UOUT(97)
27164 c$$$
27165 c$$$      DO 10 KKK = 1,97
27166 c$$$   10 UOUT(KKK) = U(KKK)
27167 c$$$      COUT  = C
27168 c$$$      CDOUT = CD
27169 c$$$      CMOUT = CM
27170 c$$$      IOUT  = I
27171 c$$$      JOUT  = J
27172 c$$$
27173 c$$$      RETURN
27174 c$$$      END
27175 c$$$
27176 c$$$*$ CREATE DT_RNDMTE.FOR
27177 c$$$*COPY DT_RNDMTE
27178 c$$$*
27179 c$$$*===rndmte=============================================================*
27180 c$$$*
27181 c$$$      SUBROUTINE DT_RNDMTE(IO)
27182 c$$$
27183 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27184 c$$$      SAVE
27185 c$$$
27186 c$$$      DIMENSION UU(97),U(6),X(6),D(6)
27187 c$$$      DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27188 c$$$     +8354498.D0, 10633180.D0/
27189 c$$$
27190 c$$$      CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27191 c$$$      CALL DT_RNDMST(12,34,56,78)
27192 c$$$      DO 10 II1 = 1,20000
27193 c$$$   10 XX = DT_RNDM(XX)
27194 c$$$      SD        = 0.0D0
27195 c$$$      DO 20 II2 = 1,6
27196 c$$$        X(II2)  = 4096.D0*(4096.D0*DT_RNDM(SD))
27197 c$$$        D(II2)  = X(II2)-U(II2)
27198 c$$$   20 SD = SD+D(II2)
27199 c$$$      CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27200 c$$$**sr 24.01.95
27201 c$$$C     IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27202 c$$$      IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27203 c$$$C        WRITE(6,1000)
27204 c$$$ 1000    FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27205 c$$$     &          ' passed')
27206 c$$$      ENDIF
27207 c$$$**
27208 c$$$      RETURN
27209 c$$$  500 FORMAT('  === TEST OF THE RANDOM-GENERATOR ===',/,
27210 c$$$     &'    EXPECTED VALUE    CALCULATED VALUE     DIFFERENCE',/, 6(F17.
27211 c$$$     &1,F20.1,F15.3,/), '  === END OF TEST ;',
27212 c$$$     &'  GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27213 c$$$      END
27214 *
27215 *$ CREATE PHO_RNDM.FOR
27216 *COPY PHO_RNDM
27217 *
27218 *===pho_rndm===========================================================*
27219 *
27220       DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27221
27222       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27223       SAVE
27224
27225       PHO_RNDM = DT_RNDM(DUMMY)
27226
27227       RETURN
27228       END
27229
27230 *$ CREATE PYR.FOR
27231 *COPY PYR
27232 *
27233 *===pyr================================================================*
27234 *
27235       DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27236
27237       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27238       SAVE
27239
27240       DUMMY = DBLE(IDUMMY)
27241       PYR = DT_RNDM(DUMMY)
27242
27243       RETURN
27244       END
27245 *$ CREATE DT_TITLE.FOR
27246 *COPY DT_TITLE
27247 *
27248 *===title==============================================================*
27249 *
27250       SUBROUTINE DT_TITLE
27251
27252       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27253       SAVE
27254
27255       PARAMETER ( LINP = 10 ,
27256      &            LOUT = 6 ,
27257      &            LDAT = 9 )
27258
27259       CHARACTER*6 CVERSI
27260       CHARACTER*11 CCHANG
27261       DATA CVERSI,CCHANG /'3.0-5 ','31 Oct 2008'/
27262
27263       CALL DT_XTIME
27264       WRITE(LOUT,1000) CVERSI,CCHANG
27265  1000 FORMAT(1X,'+-------------------------------------------------',
27266      &                  '----------------------+',/,
27267      &     1X,'|',71X,'|',/,
27268      &     1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27269      &     1X,'|',71X,'|',/,
27270      &     1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27271      &     1X,'|',71X,'|',/,
27272      &     1X,'|',12X,'Authors: Stefan Roesler   (CERN)',27X,'|',/,
27273      &     1X,'|',21X,'Ralph Engel      (FZ Karlsruhe)',19X,'|',/,
27274      &     1X,'|',21X,'Johannes Ranft   (Siegen Univ.)',19X,'|',/,
27275 C    &     1X,'|',71X,'|',/,
27276 C    &     1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27277 C    &                                              17X,'|',/,
27278      &     1X,'|',71X,'|',/,
27279      &     1X,'+-------------------------------------------------',
27280      &                '----------------------+',/,
27281      &     1X,'| Please send suggestions, bug reports, etc. to: ',
27282      &                                  'Stefan.Roesler@cern.ch |',/,
27283      &     1X,'+-------------------------------------------------',
27284      &                '----------------------+',/)
27285
27286       RETURN
27287       END
27288
27289 *$ CREATE DT_EVTINI.FOR
27290 *COPY DT_EVTINI
27291 *
27292 *===evtini=============================================================*
27293 *
27294       SUBROUTINE DT_EVTINI
27295
27296 ************************************************************************
27297 * Initialization of DTEVT1.                                            *
27298 * This version dated 15.01.94 is written by S. Roesler                 *
27299 ************************************************************************
27300
27301       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27302       SAVE
27303
27304       PARAMETER ( LINP = 10 ,
27305      &            LOUT = 6 ,
27306      &            LDAT = 9 )
27307
27308 * event history
27309
27310       PARAMETER (NMXHKK=200000)
27311
27312       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27313      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27314      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27315
27316 * extended event history
27317       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27318      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27319      &                IHIST(2,NMXHKK)
27320
27321 * event flag
27322       COMMON /DTEVNO/ NEVENT,ICASCA
27323
27324       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27325
27326 * emulsion treatment
27327       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27328      &                NCOMPO,IEMUL
27329
27330 * initialization of DTEVT1/DTEVT2
27331       NEND = NHKK
27332       IF (NEVENT.EQ.1) NEND = NMXHKK
27333       NHKK   = 0
27334       NEVHKK = NEVENT
27335       DO 1 I=1,NEND
27336          ISTHKK(I)   = 0
27337          IDHKK(I)    = 0
27338          JMOHKK(1,I) = 0
27339          JMOHKK(2,I) = 0
27340          JDAHKK(1,I) = 0
27341          JDAHKK(2,I) = 0
27342          IDRES(I)    = 0
27343          IDXRES(I)   = 0
27344          NOBAM(I)    = 0
27345          IDCH(I)     = 0
27346          IHIST(1,I)  = 0
27347          IHIST(2,I)  = 0
27348          DO 2 J=1,4
27349             PHKK(J,I) = 0.0D0
27350             VHKK(J,I) = 0.0D0
27351             WHKK(J,I) = 0.0D0
27352     2    CONTINUE
27353          PHKK(5,I) = 0.0D0
27354     1 CONTINUE
27355       DO 3 I=1,10
27356          NPOINT(I) = 0
27357     3 CONTINUE
27358       CALL DT_CHASTA(-1)
27359
27360 C* initialization of DTLTRA
27361 C      IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27362
27363       RETURN
27364       END
27365
27366 *$ CREATE DT_STATIS.FOR
27367 *COPY DT_STATIS
27368 *
27369 *===statis=============================================================*
27370 *
27371       SUBROUTINE DT_STATIS(MODE)
27372
27373 ************************************************************************
27374 * Initialization and output of run-statistics.                         *
27375 *              MODE  = 1     initialization                            *
27376 *                    = 2     output                                    *
27377 * This version dated 23.01.94 is written by S. Roesler                 *
27378 ************************************************************************
27379
27380       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27381       SAVE
27382
27383       PARAMETER ( LINP = 10 ,
27384      &            LOUT = 6 ,
27385      &            LDAT = 9 )
27386
27387       PARAMETER (TINY3=1.0D-3)
27388
27389 * statistics
27390       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27391      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27392      &                ICEVTG(8,0:30)
27393
27394 * rejection counter
27395       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27396      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27397      &                IREXCI(3),IRDIFF(2),IRINC
27398
27399 * central particle production, impact parameter biasing
27400       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27401
27402 * various options for treatment of partons (DTUNUC 1.x)
27403 * (chain recombination, Cronin,..)
27404       LOGICAL LCO2CR,LINTPT
27405       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27406      &                LCO2CR,LINTPT
27407
27408 * nucleon-nucleon event-generator
27409       CHARACTER*8 CMODEL
27410       LOGICAL LPHOIN
27411       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27412
27413 * flags for particle decays
27414       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27415      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27416      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27417
27418 * diquark-breaking mechanism
27419       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27420
27421       DIMENSION PP(4),PT(4)
27422
27423       GOTO (1,2) MODE
27424
27425 * initialization
27426     1 CONTINUE
27427
27428 *   initialize statistics counter
27429       ICREQU = 0
27430       ICSAMP = 0
27431       ICCPRO = 0
27432       ICDPR  = 0
27433       ICDTA  = 0
27434       ICRJSS = 0
27435       ICVV2S = 0
27436       DO 10 I=1,9
27437          ICRES(I)    = 0
27438          ICCHAI(1,I) = 0
27439          ICCHAI(2,I) = 0
27440    10 CONTINUE
27441 *   initialize rejection counter
27442       IRPT      = 0
27443       IRHHA     = 0
27444       LOMRES    = 0
27445       LOBRES    = 0
27446       IRFRAG    = 0
27447       IREVT     = 0
27448       IRRES(1)  = 0
27449       IRRES(2)  = 0
27450       IRCHKI(1) = 0
27451       IRCHKI(2) = 0
27452       IRCRON(1) = 0
27453       IRCRON(2) = 0
27454       IRCRON(3) = 0
27455       IRDIFF(1) = 0
27456       IRDIFF(2) = 0
27457       IRINC     = 0
27458       DO 11 I=1,5
27459          ICDIFF(I) = 0
27460    11 CONTINUE
27461       DO 12 I=1,8
27462          DO 13 J=0,30
27463             ICEVTG(I,J) = 0
27464    13    CONTINUE
27465    12 CONTINUE
27466
27467       RETURN
27468
27469 * output
27470     2 CONTINUE
27471
27472 *   statistics counter
27473       WRITE(LOUT,1000)
27474  1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27475      &       28X,'---------------------')
27476       IF (ICREQU.GT.0) THEN
27477       WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27478  1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27479      &       I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27480      &       'event',11X,F9.1)
27481       ENDIF
27482       IF (ICDIFF(1).NE.0) THEN
27483          WRITE(LOUT,1009) ICDIFF
27484  1009    FORMAT(/,1X,'diffractive events:    total   ',I8,/,49X,
27485      &          'low mass   high mass',/,24X,'single diffraction',
27486      &          7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27487       ENDIF
27488       IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
27489          WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27490      &                    DBLE(ICSAMP)/DBLE(ICCPRO)
27491  1002    FORMAT(/,1X,'central production:',/,2X,'mean number',
27492      &          ' of sampled Glauber-events per event',9X,F9.1,/,
27493      &          2X,'fraction of production cross section',21X,F10.6)
27494       ENDIF
27495       IF (ICSAMP.GT.0) THEN
27496       WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27497      &                 DBLE(ICDTA)/DBLE(ICSAMP)
27498  1003 FORMAT(/,54X,'proj.    targ.',/,1X,'average number of wounded',
27499      &       ' nucleons after x-sampling',2(4X,F6.2))
27500       ENDIF
27501
27502       IF (MCGENE.EQ.1) THEN
27503          IF (ICSAMP.GT.0) THEN
27504          WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27505  1004    FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27506      &          ' event',3X,F9.1)
27507          IF (ISICHA.EQ.1) THEN
27508             WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27509  1005       FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27510      &             'of single chains  per event',13X,F9.1)
27511          ENDIF
27512          ENDIF
27513          IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
27514          WRITE(LOUT,1006)
27515  1006    FORMAT(/,1X,'chain system statistics:  (per event)',/,
27516      &       23X,'mean number of chains      mean number of chains',/,
27517      &       23X,'sampled    hadronized      having mass of a reso.')
27518          WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27519      &                     DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27520      &                     DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27521      &                  DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27522  1007    FORMAT(1X,'sea     - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27523      &          1X,'disea   - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27524      &          1X,'sea     - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27525      &          1X,'sea     - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27526      &          1X,'disea   - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27527      &          1X,'valence - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27528      &          1X,'valence - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27529      &          1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27530      &          1X,'fused chains      ',18X,F4.1,17X,F4.1,/)
27531          WRITE(LOUT,1008)
27532      &     (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27533      &     DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27534      &     DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27535      &     (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27536      &     (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27537      &     DBLE(IRHHA)/DBLE(ICREQU),
27538      &     DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27539      &     (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27540  1008    FORMAT(/,1X,'Rejection counter:  (NEVT = no. of events)',/,/,
27541      &       1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27542      &       F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27543      &       'Intrins. p_t (GETSPT)',21X,'IRPT     /NEVT = ',F7.2,/,
27544      &       1X,'Chain mass corr. for resonances (EVTRES)',2X,
27545      &       'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES)  IRRES(2) /',
27546      &       'NEVT = ',F7.2,/,43X,'LOMRES   /NEVT = ',F7.2,/,
27547      &       43X,'LOBRES   /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27548      &       ' 2-chain systems (CHKINE)  IRCHKI(1)/NEVT = ',F7.2,/,
27549      &       43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27550      &       'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27551      &       F7.2,/,1X,'Total no. of rej.',
27552      &       ' in chain-systems treatment (GETCSY)',/,43X,
27553      &       'IRHHA    /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27554      &       ' (not yet used!)',4X,'IRFRAG   /NEVT = ',F7.2,/,
27555      &       1X,'Total no. of rej. in DPM-treatment of one event',
27556      &       ' (EVENTA)',/,43X,'IREVT    /NEVT = ',F7.2,/,1X,
27557      &       'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27558      &       ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27559      &       'IREXCI(3) = ',I5,/)
27560          ENDIF
27561       ELSEIF (MCGENE.EQ.2) THEN
27562          WRITE(LOUT,1010) ELOJET
27563  1010    FORMAT(/,/,1X,'PHOJET-treatment of chain systems above  ',
27564      &          F4.1,' GeV')
27565          WRITE(LOUT,1011)
27566  1011    FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27567      &          30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27568      &          5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27569          WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27570      &                    (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27571      &                    (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27572      &                    ((ICEVTG(I,J),I=1,8),J=3,7),
27573      &                    ((ICEVTG(I,J),I=1,8),J=19,21),
27574      &                    (ICEVTG(I,8),I=1,8),
27575      &                    ((ICEVTG(I,J),I=1,8),J=22,24),
27576      &                    (ICEVTG(I,9),I=1,8),
27577      &                    ((ICEVTG(I,J),I=1,8),J=25,28),
27578      &                    ((ICEVTG(I,J),I=1,8),J=10,18)
27579  1012    FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27580      &          8I8,/,/,1X,'PHOJET ',8I8,/,'   sngl ',8I8,/,/,
27581      &          ' no-dif.',8I8,/,
27582      &          ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27583      &          ' diff-1 ',8I8,/,'  low   ',8I8,/,'  high  ',8I8,/,
27584      &          '  h-diff',8I8,/,' diff-2 ',8I8,/,'  low   ',8I8,/,
27585      &          '  high  ',8I8,/,'  h-diff',8I8,/,' dbl-di.',8I8,/,
27586      &          '  lo-lo ',8I8,/,'  hi-hi ',8I8,/,'  lo-hi ',8I8,/,
27587      &          '  hi-lo ',8I8,/,
27588      &          ' dir-ga.',8I8,/,/,' dir-1  ',8I8,/,' dir-2  ',8I8,/,
27589      &          ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27590      &          ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27591          WRITE(LOUT,1013)
27592  1013    FORMAT(/,1X,'2. chain system statistics -',
27593      &          ' mean numbers per evt:',/,30X,'---------------------',
27594      &          /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27595          IF (ICSAMP.GT.0) THEN
27596          WRITE(LOUT,1014)
27597      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27598      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27599      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27600  1014    FORMAT(/,1X,'req.to.    ',3E10.2,/,/,1X,'low rq.    ',3E10.2,/,
27601      &          1X,'low ac.    ',3E10.2,/,/,1X,'PHOJET     ',3E10.2,/,/,
27602      &          ' no-dif.    ',3E10.2,/,' el-sca.    ',3E10.2,/,
27603      &          ' qel-sc.    ',3E10.2,/,' dbl-Po.    ',3E10.2,/,
27604      &          ' diff-1     ',3E10.2,/,' diff-2     ',3E10.2,/,
27605      &          ' dbl-di.    ',3E10.2,/,' dir-ga.    ',3E10.2,/,/,
27606      &          ' dir-1      ',3E10.2,/,' dir-2      ',3E10.2,/,
27607      &          ' dbl-dir    ',3E10.2,/,' s-Pom.     ',3E10.2,/,
27608      &          ' h-Pom.     ',3E10.2,/,' s-Reg.     ',3E10.2,/,
27609      &          ' enh-trg    ',3E10.2,/,' enh-log    ',3E10.2)
27610          ENDIF
27611          WRITE(LOUT,1015)
27612  1015    FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27613          IF (ICSAMP.GT.0) THEN
27614          WRITE(LOUT,1016)
27615      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27616      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27617      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27618  1016    FORMAT(/,1X,'req.to.    ',5E10.2,/,/,1X,'low rq.    ',5E10.2,/,
27619      &          1X,'low ac.    ',5E10.2,/,/,1X,'PHOJET     ',5E10.2,/,/,
27620      &          ' no-dif.    ',5E10.2,/,' el-sca.    ',5E10.2,/,
27621      &          ' qel-sc.    ',5E10.2,/,' dbl-Po.    ',5E10.2,/,
27622      &          ' diff-1     ',5E10.2,/,' diff-2     ',5E10.2,/,
27623      &          ' dbl-di.    ',5E10.2,/,' dir-ga.    ',5E10.2,/,/,
27624      &          ' dir-1      ',5E10.2,/,' dir-2      ',5E10.2,/,
27625      &          ' dbl-dir    ',5E10.2,/,' s-Pom.     ',5E10.2,/,
27626      &          ' h-Pom.     ',5E10.2,/,' s-Reg.     ',5E10.2,/,
27627      &          ' enh-trg    ',5E10.2,/,' enh-log    ',5E10.2)
27628          ENDIF
27629
27630       ENDIF
27631       CALL DT_CHASTA(1)
27632
27633       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27634      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
27635          WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27636      &    DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27637      &    DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27638          WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27639      &    DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27640      &    DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27641          WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27642      &    DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27643      &    DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27644          WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27645      &    DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27646      &    DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27647          WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27648      &    DBRKA(3,1),DBRKA(3,2),
27649      &    DBRKA(3,3),DBRKA(3,4)
27650          WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27651      &    DBRKR(3,1),DBRKR(3,2),
27652      &    DBRKR(3,3),DBRKR(3,4)
27653          WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27654      &    DBRKA(3,5),DBRKA(3,6),
27655      &    DBRKA(3,7),DBRKA(3,8)
27656          WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27657      &    DBRKR(3,5),DBRKR(3,6),
27658      &    DBRKR(3,7),DBRKR(3,8)
27659       ENDIF
27660
27661       FAC = 1.0D0
27662       IF (MCGENE.EQ.2) THEN
27663
27664 C        CALL PHO_PHIST(-2,SIGMAX)
27665          CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27666
27667       ENDIF
27668
27669       CALL DT_XTIME
27670
27671       RETURN
27672       END
27673
27674 *$ CREATE DT_EVTOUT.FOR
27675 *COPY DT_EVTOUT
27676 *
27677 *===evtout=============================================================*
27678 *
27679       SUBROUTINE DT_EVTOUT(MODE)
27680
27681 ************************************************************************
27682 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27683 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27684 *                    4  plot entries of DTEVT1 and DTEVT2              *
27685 * This version dated 11.12.94 is written by S. Roesler                 *
27686 ************************************************************************
27687
27688       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27689       SAVE
27690
27691       PARAMETER ( LINP = 10 ,
27692      &            LOUT = 6 ,
27693      &            LDAT = 9 )
27694
27695 * event history
27696
27697       PARAMETER (NMXHKK=200000)
27698
27699       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27700      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27701      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27702
27703       DIMENSION IRANGE(NMXHKK)
27704
27705       IF (MODE.EQ.2) RETURN
27706
27707       CALL DT_EVTPLO(IRANGE,MODE)
27708
27709       RETURN
27710       END
27711
27712 *$ CREATE DT_EVTPLO.FOR
27713 *COPY DT_EVTPLO
27714 *
27715 *===evtplo=============================================================*
27716 *
27717       SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27718
27719 ************************************************************************
27720 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27721 *                    2  plot entries of DTEVT1 given by IRANGE         *
27722 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27723 *                    4  plot entries of DTEVT1 and DTEVT2              *
27724 *                    5  plot rejection counter                         *
27725 * This version dated 11.12.94 is written by S. Roesler                 *
27726 ************************************************************************
27727
27728       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27729       SAVE
27730
27731       PARAMETER ( LINP = 10 ,
27732      &            LOUT = 6 ,
27733      &            LDAT = 9 )
27734
27735       CHARACTER*16 CHAU
27736
27737 * event history
27738
27739       PARAMETER (NMXHKK=200000)
27740
27741       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27742      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27743      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27744
27745 * extended event history
27746       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27747      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27748      &                IHIST(2,NMXHKK)
27749
27750 * rejection counter
27751       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27752      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27753      &                IREXCI(3),IRDIFF(2),IRINC
27754
27755       DIMENSION IRANGE(NMXHKK)
27756
27757       IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
27758          WRITE(LOUT,1000)
27759  1000    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTEVT1/',/,
27760      &         15X,'           --------------------------',/,/,
27761      &             '       ST    ID  M1   M2   D1   D2     PX     PY',
27762      &             '     PZ      E       M',/)
27763          DO 1 I=1,NHKK
27764             WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27765      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27766      &                       PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27767      &                       PHKK(5,I)
27768 C           WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27769 C    &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27770 C    &                       PHKK(3,I),PHKK(4,I)
27771 C           WRITE(LOUT,'(4E15.4)')
27772 C    &         VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
27773  1001       FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
27774  1011       FORMAT(I5,I5,I6,4I5,2E15.5)
27775     1    CONTINUE
27776          WRITE(LOUT,*)
27777 C        DO 4 I=1,NHKK
27778 C           WRITE(LOUT,1006) I,ISTHKK(I),
27779 C    &                    VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
27780 C    &                    WHKK(2,I),WHKK(3,I)
27781 C1006       FORMAT(1X,I4,I6,6E10.3)
27782 C   4    CONTINUE
27783       ENDIF
27784
27785       IF (MODE.EQ.2) THEN
27786          WRITE(LOUT,1000)
27787          NC = 0
27788     2    CONTINUE
27789          NC = NC+1
27790          IF (IRANGE(NC).EQ.-100) GOTO 9999
27791          I = IRANGE(NC)
27792          WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27793      &                    JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27794      &                    PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27795      &                    PHKK(5,I)
27796          GOTO 2
27797       ENDIF
27798
27799       IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
27800          WRITE(LOUT,1002)
27801  1002    FORMAT(/,1X,'EVTPLO:',14X,
27802      &         ' content of COMMON /DTEVT1/,/DTEVT2/',/,
27803      &         15X,'        -----------------------------------',/,/,
27804      &             '       ST    ID   M1   M2   D1   D2  IDR  IDXR',
27805      &             ' NOBAM IDCH    M',/)
27806          DO 3 I=1,NHKK
27807 C           IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
27808                KF    = IDHKK(I)
27809                IDCHK = KF/10000
27810                IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
27811      &            (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
27812
27813                CALL PYNAME(KF,CHAU)
27814
27815                WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27816      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27817      &                       IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
27818      &                       PHKK(5,I),CHAU
27819  1003          FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
27820 C           ENDIF
27821     3    CONTINUE
27822       ENDIF
27823
27824       IF (MODE.EQ.5) THEN
27825          WRITE(LOUT,1004)
27826  1004    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTREJC/',/,
27827      &         15X,'           --------------------------',/)
27828          WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
27829      &                    IRSEA,IRCRON
27830  1005    FORMAT(1X,'IRPT   = ',I5,'  IRHHA = ',I5,/,
27831      &          1X,'IRRES  = ',2I5,'  LOMRES = ',I5,'  LOBRES = ',I5,/,
27832      &          1X,'IREMC  = ',10I5,/,
27833      &          1X,'IRFRAG = ',I5,'  IRSEA = ',I5,' IRCRON = ',I5,/)
27834       ENDIF
27835
27836  9999 RETURN
27837       END
27838
27839 *$ CREATE DT_EVTPUT.FOR
27840 *COPY DT_EVTPUT
27841 *
27842 *===evtput=============================================================*
27843 *
27844       SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
27845
27846       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27847       SAVE
27848
27849       PARAMETER ( LINP = 10 ,
27850      &            LOUT = 6 ,
27851      &            LDAT = 9 )
27852
27853       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
27854      &           TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
27855
27856 * event history
27857
27858       PARAMETER (NMXHKK=200000)
27859
27860       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27861      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27862      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27863
27864 * extended event history
27865       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27866      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27867      &                IHIST(2,NMXHKK)
27868
27869 * Lorentz-parameters of the current interaction
27870       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27871      &                UMO,PPCM,EPROJ,PPROJ
27872
27873 * particle properties (BAMJET index convention)
27874       CHARACTER*8  ANAME
27875       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27876      &                IICH(210),IIBAR(210),K1(210),K2(210)
27877
27878 C     IF (MODE.GT.100) THEN
27879 C        WRITE(LOUT,'(1X,A,I5,A,I5)')
27880 C    &        'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
27881 C        NHKK = NHKK-MODE+100
27882 C        RETURN
27883 C     ENDIF
27884       MO1  = M1
27885       MO2  = M2
27886       NHKK = NHKK+1
27887
27888       IF (NHKK.GT.NMXHKK) THEN
27889          WRITE(LOUT,1000) NHKK
27890  1000    FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
27891      &             '! program execution stopped..')
27892          STOP
27893       ENDIF
27894       IF (M1.LT.0) MO1 = NHKK+M1
27895       IF (M2.LT.0) MO2 = NHKK+M2
27896       ISTHKK(NHKK)   = IST
27897       IDHKK(NHKK)    = ID
27898       JMOHKK(1,NHKK) = MO1
27899       JMOHKK(2,NHKK) = MO2
27900       JDAHKK(1,NHKK) = 0
27901       JDAHKK(2,NHKK) = 0
27902       IDRES(NHKK)    = IDR
27903       IDXRES(NHKK)   = IDXR
27904       IDCH(NHKK)     = IDC
27905 ** here we need to do something..
27906       IF (ID.EQ.88888) THEN
27907          IDMO1 = ABS(IDHKK(MO1))
27908          IDMO2 = ABS(IDHKK(MO2))
27909          IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
27910          IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
27911          IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
27912          IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
27913       ELSE
27914          NOBAM(NHKK) = 0
27915       ENDIF
27916       IDBAM(NHKK) = IDT_ICIHAD(ID)
27917       IF (MO1.GT.0) THEN
27918          IF (JDAHKK(1,MO1).NE.0) THEN
27919             JDAHKK(2,MO1) = NHKK
27920          ELSE
27921             JDAHKK(1,MO1) = NHKK
27922          ENDIF
27923       ENDIF
27924       IF (MO2.GT.0) THEN
27925          IF (JDAHKK(1,MO2).NE.0) THEN
27926             JDAHKK(2,MO2) = NHKK
27927          ELSE
27928             JDAHKK(1,MO2) = NHKK
27929          ENDIF
27930       ENDIF
27931 C      IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
27932 C         PTOT   = SQRT(PX**2+PY**2+PZ**2)
27933 C         AM0    = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
27934 C         AMRQ   = AAM(IDBAM(NHKK))
27935 C         AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
27936 C         IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
27937 C     &       (PTOT.GT.ZERO)) THEN
27938 C            DELTA = -AMDIF2/(2.0D0*(E+PTOT))
27939 CC           DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
27940 C            E     = E+DELTA
27941 C            PTOT1 = PTOT-DELTA
27942 C            PX    = PX*PTOT1/PTOT
27943 C            PY    = PY*PTOT1/PTOT
27944 C            PZ    = PZ*PTOT1/PTOT
27945 C         ENDIF
27946 C      ENDIF
27947       PHKK(1,NHKK) = PX
27948       PHKK(2,NHKK) = PY
27949       PHKK(3,NHKK) = PZ
27950       PHKK(4,NHKK) = E
27951       PTOT = SQRT( PX**2+PY**2+PZ**2 )
27952       IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
27953          PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
27954          PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
27955       ELSE
27956          PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
27957 C        IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
27958 C    &      WRITE(LOUT,'(1X,A,G10.3)')
27959 C    &        'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
27960          PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
27961       ENDIF
27962       IDCHK = ID/10000
27963       IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
27964 * special treatment for chains:
27965 *    z coordinate of chain in Lab  = pos. of target nucleon
27966 *    time of chain-creation in Lab = time of passage of projectile
27967 *                                    nucleus at pos. of taget nucleus
27968 C        VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
27969 C        VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
27970          VHKK(1,NHKK) = VHKK(1,MO2)
27971          VHKK(2,NHKK) = VHKK(2,MO2)
27972          VHKK(3,NHKK) = VHKK(3,MO2)
27973          VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
27974 C        WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
27975 C        WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
27976          WHKK(1,NHKK) = WHKK(1,MO1)
27977          WHKK(2,NHKK) = WHKK(2,MO1)
27978          WHKK(3,NHKK) = WHKK(3,MO1)
27979          WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
27980       ELSE
27981          IF (MO1.GT.0) THEN
27982             DO 1 I=1,4
27983                VHKK(I,NHKK) = VHKK(I,MO1)
27984                WHKK(I,NHKK) = WHKK(I,MO1)
27985     1       CONTINUE
27986          ELSE
27987             DO 2 I=1,4
27988                VHKK(I,NHKK) = ZERO
27989                WHKK(I,NHKK) = ZERO
27990     2       CONTINUE
27991          ENDIF
27992       ENDIF
27993
27994       RETURN
27995       END
27996
27997 *$ CREATE DT_CHASTA.FOR
27998 *COPY DT_CHASTA
27999 *
28000 *===chasta=============================================================*
28001 *
28002       SUBROUTINE DT_CHASTA(MODE)
28003
28004 ************************************************************************
28005 * This subroutine performs CHAin STAtistics and checks sequence of     *
28006 * partons in dtevt1 and sorts them with projectile partons coming      *
28007 * first if necessary.                                                  *
28008 *                                                                      *
28009 * This version dated  8.5.00  is written by S. Roesler.                *
28010 ************************************************************************
28011
28012       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28013       SAVE
28014
28015       PARAMETER ( LINP = 10 ,
28016      &            LOUT = 6 ,
28017      &            LDAT = 9 )
28018
28019       CHARACTER*5 CCHTYP
28020
28021 * event history
28022
28023       PARAMETER (NMXHKK=200000)
28024
28025       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28026      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28027      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28028
28029 * extended event history
28030       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28031      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28032      &                IHIST(2,NMXHKK)
28033
28034 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28035       PARAMETER (MAXCHN=10000)
28036       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28037
28038       DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28039      &          CCHTYP(9),ICHSTA(10),ITOT(10)
28040       DATA ICHCFG /1800*0/
28041       DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28042       DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28043       DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28044       DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28045       DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28046       DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28047       DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28048      &              'ad aq',' d ad','ad d ',' g g '/
28049 *
28050 * initialization
28051 *
28052       IF (MODE.EQ.-1) THEN
28053          NCHAIN = 0
28054 *
28055 * loop over DTEVT1 and analyse chain configurations
28056 *
28057       ELSEIF (MODE.EQ.0) THEN
28058          DO 21 IDX=NPOINT(3),NHKK
28059             IDCHK = IDHKK(IDX)/10000
28060             IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28061      &          (IDHKK(IDX).NE.80000).AND.
28062      &          (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28063                IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28064                   WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28065      &                          ' at entry ',IDX
28066                   GOTO 21
28067                ENDIF
28068 *
28069                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28070                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28071                IMO1 = IST1/10
28072                IMO1 = IST1-10*IMO1
28073                IMO2 = IST2/10
28074                IMO2 = IST2-10*IMO2
28075 *   swop parton entries if necessary since we need projectile partons
28076 *   to come first in the common
28077                IF (IMO1.GT.IMO2) THEN
28078                   NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28079                   DO 22 K=1,NPTN/2
28080                      I0 = JMOHKK(1,IDX)-1+K
28081                      I1 = JMOHKK(2,IDX)+1-K
28082                      ITMP = ISTHKK(I0)
28083                      ISTHKK(I0) = ISTHKK(I1)
28084                      ISTHKK(I1) = ITMP
28085                      ITMP = IDHKK(I0)
28086                      IDHKK(I0) = IDHKK(I1)
28087                      IDHKK(I1) = ITMP
28088                      IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28089      &                  JDAHKK(1,JMOHKK(1,I0)) = I1
28090                      IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28091      &                  JDAHKK(2,JMOHKK(1,I0)) = I1
28092                      IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28093      &                  JDAHKK(1,JMOHKK(2,I0)) = I1
28094                      IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28095      &                  JDAHKK(2,JMOHKK(2,I0)) = I1
28096                      IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28097      &                  JDAHKK(1,JMOHKK(1,I1)) = I0
28098                      IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28099      &                  JDAHKK(2,JMOHKK(1,I1)) = I0
28100                      IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28101      &                  JDAHKK(1,JMOHKK(2,I1)) = I0
28102                      IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28103      &                  JDAHKK(2,JMOHKK(2,I1)) = I0
28104                      ITMP = JMOHKK(1,I0)
28105                      JMOHKK(1,I0) = JMOHKK(1,I1)
28106                      JMOHKK(1,I1) = ITMP
28107                      ITMP = JMOHKK(2,I0)
28108                      JMOHKK(2,I0) = JMOHKK(2,I1)
28109                      JMOHKK(2,I1) = ITMP
28110                      ITMP = JDAHKK(1,I0)
28111                      JDAHKK(1,I0) = JDAHKK(1,I1)
28112                      JDAHKK(1,I1) = ITMP
28113                      ITMP = JDAHKK(2,I0)
28114                      JDAHKK(2,I0) = JDAHKK(2,I1)
28115                      JDAHKK(2,I1) = ITMP
28116                      DO 23 J=1,4
28117                         RTMP1 = PHKK(J,I0)
28118                         RTMP2 = VHKK(J,I0)
28119                         RTMP3 = WHKK(J,I0)
28120                         PHKK(J,I0) = PHKK(J,I1)
28121                         VHKK(J,I0) = VHKK(J,I1)
28122                         WHKK(J,I0) = WHKK(J,I1)
28123                         PHKK(J,I1) = RTMP1
28124                         VHKK(J,I1) = RTMP2
28125                         WHKK(J,I1) = RTMP3
28126    23                CONTINUE
28127                      RTMP1 = PHKK(5,I0)
28128                      PHKK(5,I0) = PHKK(5,I1)
28129                      PHKK(5,I1) = RTMP1
28130                      ITMP = IDRES(I0)
28131                      IDRES(I0) = IDRES(I1)
28132                      IDRES(I1) = ITMP
28133                      ITMP = IDXRES(I0)
28134                      IDXRES(I0) = IDXRES(I1)
28135                      IDXRES(I1) = ITMP
28136                      ITMP = NOBAM(I0)
28137                      NOBAM(I0) = NOBAM(I1)
28138                      NOBAM(I1) = ITMP
28139                      ITMP = IDBAM(I0)
28140                      IDBAM(I0) = IDBAM(I1)
28141                      IDBAM(I1) = ITMP
28142                      ITMP = IDCH(I0)
28143                      IDCH(I0) = IDCH(I1)
28144                      IDCH(I1) = ITMP
28145                      ITMP = IHIST(1,I0)
28146                      IHIST(1,I0) = IHIST(1,I1)
28147                      IHIST(1,I1) = ITMP
28148                      ITMP = IHIST(2,I0)
28149                      IHIST(2,I0) = IHIST(2,I1)
28150                      IHIST(2,I1) = ITMP
28151    22             CONTINUE
28152                ENDIF
28153                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28154                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28155 *
28156 *   parton 1 (projectile side)
28157                IF (IST1.EQ.21) THEN
28158                   IDX1 = 1
28159                ELSEIF (IST1.EQ.22) THEN
28160                   IDX1 = 2
28161                ELSEIF (IST1.EQ.31) THEN
28162                   IDX1 = 3
28163                ELSEIF (IST1.EQ.32) THEN
28164                   IDX1 = 4
28165                ELSEIF (IST1.EQ.41) THEN
28166                   IDX1 = 5
28167                ELSEIF (IST1.EQ.42) THEN
28168                   IDX1 = 6
28169                ELSEIF (IST1.EQ.51) THEN
28170                   IDX1 = 7
28171                ELSEIF (IST1.EQ.52) THEN
28172                   IDX1 = 8
28173                ELSEIF (IST1.EQ.61) THEN
28174                   IDX1 = 9
28175                ELSEIF (IST1.EQ.62) THEN
28176                   IDX1 = 10
28177                ELSE
28178 c                 WRITE(LOUT,*)
28179 c    &               ' CHASTA: unknown parton status flag (',
28180 c    &               IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28181                   GOTO 21
28182                ENDIF
28183                ID = IDHKK(JMOHKK(1,IDX))
28184                IF (ABS(ID).LE.4) THEN
28185                   IF (ID.GT.0) THEN
28186                      ITYP1 = 1
28187                   ELSE
28188                      ITYP1 = 2
28189                   ENDIF
28190                ELSEIF (ABS(ID).GE.1000) THEN
28191                   IF (ID.GT.0) THEN
28192                      ITYP1 = 3
28193                   ELSE
28194                      ITYP1 = 4
28195                   ENDIF
28196                ELSEIF (ID.EQ.21) THEN
28197                   ITYP1 = 5
28198                ELSE
28199                   WRITE(LOUT,*)
28200      &               ' CHASTA: inconsistent parton identity (',
28201      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28202                   GOTO 21
28203                ENDIF
28204 *
28205 *   parton 2 (target side)
28206                IF (IST2.EQ.21) THEN
28207                   IDX2 = 1
28208                ELSEIF (IST2.EQ.22) THEN
28209                   IDX2 = 2
28210                ELSEIF (IST2.EQ.31) THEN
28211                   IDX2 = 3
28212                ELSEIF (IST2.EQ.32) THEN
28213                   IDX2 = 4
28214                ELSEIF (IST2.EQ.41) THEN
28215                   IDX2 = 5
28216                ELSEIF (IST2.EQ.42) THEN
28217                   IDX2 = 6
28218                ELSEIF (IST2.EQ.51) THEN
28219                   IDX2 = 7
28220                ELSEIF (IST2.EQ.52) THEN
28221                   IDX2 = 8
28222                ELSEIF (IST2.EQ.61) THEN
28223                   IDX2 = 9
28224                ELSEIF (IST2.EQ.62) THEN
28225                   IDX2 = 10
28226                ELSE
28227 c                 WRITE(LOUT,*)
28228 c    &               ' CHASTA: unknown parton status flag (',
28229 c    &               IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28230                   GOTO 21
28231                ENDIF
28232                ID = IDHKK(JMOHKK(2,IDX))
28233                IF (ABS(ID).LE.4) THEN
28234                   IF (ID.GT.0) THEN
28235                      ITYP2 = 1
28236                   ELSE
28237                      ITYP2 = 2
28238                   ENDIF
28239                ELSEIF (ABS(ID).GE.1000) THEN
28240                   IF (ID.GT.0) THEN
28241                      ITYP2 = 3
28242                   ELSE
28243                      ITYP2 = 4
28244                   ENDIF
28245                ELSEIF (ID.EQ.21) THEN
28246                   ITYP2 = 5
28247                ELSE
28248                   WRITE(LOUT,*)
28249      &               ' CHASTA: inconsistent parton identity (',
28250      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28251                   GOTO 21
28252                ENDIF
28253 *
28254 *   fill counter
28255                ITYPE = ICHTYP(ITYP1,ITYP2)
28256                IF (ITYPE.NE.0) THEN
28257                   ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28258                   NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28259                   ICHCFG(IDX1,IDX2,ITYPE,2) =
28260      &               ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28261
28262                   NCHAIN = NCHAIN+1
28263                   IF (NCHAIN.GT.MAXCHN) THEN
28264                      WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28265      &                  NCHAIN,MAXCHN
28266                      STOP
28267                   ENDIF
28268                   IDXCHN(1,NCHAIN) = IDX
28269                   IDXCHN(2,NCHAIN) = ITYPE
28270                ELSE
28271                   WRITE(LOUT,*)
28272      &               ' CHASTA: inconsistent chain at entry ',IDX
28273                   GOTO 21
28274                ENDIF
28275             ENDIF
28276    21    CONTINUE
28277 *
28278 * write statistics to output unit
28279 *
28280       ELSEIF (MODE.EQ.1) THEN
28281          WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28282          DO 31 I=1,10
28283             WRITE(LOUT,'(/,2A)')
28284      &         ' -----------------------------------------',
28285      &         '------------------------------------'
28286             WRITE(LOUT,'(2A)')
28287      &         ' p\\t         21     22     31     32     41',
28288      &         '     42     51     52     61     62'
28289             WRITE(LOUT,'(2A)')
28290      &         ' -----------------------------------------',
28291      &         '------------------------------------'
28292             DO 32 J=1,10
28293                ITOT(J) = 0
28294                DO 33 K=1,9
28295                   ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28296    33          CONTINUE
28297    32       CONTINUE
28298             WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28299             DO 34 K=1,9
28300                ISUM = 0
28301                DO 35 J=1,10
28302                   ISUM = ISUM+ICHCFG(I,J,K,1)
28303    35          CONTINUE
28304                IF (ISUM.GT.0)
28305      &            WRITE(LOUT,'(1X,A5,2X,10I7)')
28306      &               CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28307    34       CONTINUE
28308 C           WRITE(LOUT,'(2A)')
28309 C    &         ' -----------------------------------------',
28310 C    &         '-------------------------------'
28311    31    CONTINUE
28312 *
28313       ELSE
28314          WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28315          STOP
28316       ENDIF
28317
28318       RETURN
28319       END
28320 *$ CREATE PHO_PHIST.FOR
28321 *COPY PHO_PHIST
28322 *
28323 *===pohist=============================================================*
28324 *
28325       SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28326
28327       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28328       SAVE
28329
28330       PARAMETER ( LINP = 10 ,
28331      &            LOUT = 6 ,
28332      &            LDAT = 9 )
28333
28334       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28335
28336 * Glauber formalism: cross sections
28337       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28338      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28339      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28340      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28341      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28342      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28343      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28344      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28345      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28346      &                BSLOPE,NEBINI,NQBINI
28347
28348       ILAB = 0
28349       IF (IMODE.EQ.10) THEN
28350          IMODE = 1
28351          ILAB  = 1
28352       ENDIF
28353       IF (ABS(IMODE).LT.1000) THEN
28354 * PHOJET-statistics
28355 C        CALL POHISX(IMODE,WEIGHT)
28356          IF (IMODE.EQ.-1) THEN
28357             MODE = 1
28358             XSTOT(1,1,1) = WEIGHT
28359          ENDIF
28360          IF (IMODE.EQ. 1) MODE = 2
28361          IF (IMODE.EQ.-2) MODE = 3
28362          IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28363 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28364 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28365          CALL DT_HISTOG(MODE)
28366          CALL DT_USRHIS(MODE)
28367       ELSE
28368 * DTUNUC-statistics
28369          MODE = IMODE/1000
28370 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28371 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28372          CALL DT_HISTOG(MODE)
28373          CALL DT_USRHIS(MODE)
28374       ENDIF
28375
28376       RETURN
28377       END
28378
28379 *$ CREATE DT_SWPPHO.FOR
28380 *COPY DT_SWPPHO
28381 *
28382 *===swppho=============================================================*
28383 *
28384       SUBROUTINE DT_SWPPHO(ILAB)
28385
28386       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28387       SAVE
28388
28389       PARAMETER ( LINP = 10 ,
28390      &            LOUT = 6 ,
28391      &            LDAT = 9 )
28392
28393       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28394
28395       LOGICAL LSTART
28396
28397 * event history
28398
28399       PARAMETER (NMXHKK=200000)
28400
28401       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28402      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28403      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28404
28405 * extended event history
28406       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28407      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28408      &                IHIST(2,NMXHKK)
28409
28410 * flags for input different options
28411       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28412       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28413      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28414
28415 * properties of photon/lepton projectiles
28416       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28417
28418 **PHOJET105a
28419 C     PARAMETER (NMXHEP=2000)
28420 C     COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28421 C    &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28422 C     COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28423 C     COMMON /PLASAV/ PLAB
28424 **PHOJET110
28425 C  standard particle data interface
28426       INTEGER NMXHEP
28427
28428       PARAMETER (NMXHEP=4000)
28429
28430       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28431       DOUBLE PRECISION PHEP,VHEP
28432       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28433      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28434      &                VHEP(4,NMXHEP)
28435 C  extension to standard particle data interface (PHOJET specific)
28436       INTEGER IMPART,IPHIST,ICOLOR
28437       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28438
28439 C  global event kinematics and particle IDs
28440       INTEGER IFPAP,IFPAB
28441       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28442       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28443 **
28444       DATA ICOUNT/0/
28445
28446       DATA LSTART /.TRUE./
28447
28448 C     IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28449       IF ((IFRAME.EQ.1).AND.LSTART) THEN
28450          UMO  = ECM
28451          ELA  = ZERO
28452          PLA  = ZERO
28453          IDP  = IDT_ICIHAD(IFPAP(1))
28454          IDT  = IDT_ICIHAD(IFPAP(2))
28455          VIRT = PVIRT(1)
28456          CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28457          PLAB = PLA
28458          LSTART = .FALSE.
28459       ENDIF
28460
28461       NHKK   = 0
28462       ICOUNT = ICOUNT+1
28463 C     NEVHKK = NEVHEP
28464       NEVHKK = ICOUNT
28465       IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28466       DO 1 I=3,NHEP
28467          IF (ISTHEP(I).EQ.1) THEN
28468             NHKK = NHKK+1
28469             ISTHKK(NHKK) = 1
28470             IDHKK(NHKK)  = IDHEP(I)
28471             JMOHKK(1,NHKK) = 0
28472             JMOHKK(2,NHKK) = 0
28473             JDAHKK(1,NHKK) = 0
28474             JDAHKK(2,NHKK) = 0
28475             DO 2 K=1,4
28476                PHKK(K,NHKK) = PHEP(K,I)
28477                VHKK(K,NHKK) = ZERO
28478                WHKK(K,NHKK) = ZERO
28479     2       CONTINUE
28480             IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28481      &         CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28482      &                    PHKK(3,NHKK),PHKK(4,NHKK),-3)
28483             PHKK(5,NHKK) = PHEP(5,I)
28484             IDRES(NHKK)  = 0
28485             IDXRES(NHKK) = 0
28486             NOBAM(NHKK)  = 0
28487             IDBAM(NHKK)  = IDT_ICIHAD(IDHEP(I))
28488             IDCH(NHKK)   = 0
28489          ENDIF
28490     1 CONTINUE
28491
28492       RETURN
28493       END
28494
28495 *$ CREATE DT_HISTOG.FOR
28496 *COPY DT_HISTOG
28497 *
28498 *===histog=============================================================*
28499 *
28500       SUBROUTINE DT_HISTOG(MODE)
28501
28502 ************************************************************************
28503 * This version dated 25.03.96 is written by S. Roesler                 *
28504 ************************************************************************
28505
28506       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28507       SAVE
28508
28509       PARAMETER ( LINP = 10 ,
28510      &            LOUT = 6 ,
28511      &            LDAT = 9 )
28512
28513       LOGICAL LFSP,LRNL
28514
28515 * event history
28516
28517       PARAMETER (NMXHKK=200000)
28518
28519       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28520      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28521      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28522
28523 * extended event history
28524       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28525      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28526      &                IHIST(2,NMXHKK)
28527
28528 * event flag used for histograms
28529       COMMON /DTNORM/ ICEVT,IEVHKK
28530
28531 * flags for activated histograms
28532       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28533
28534       IEVHKK = NEVHKK
28535       GOTO (1,2,3) MODE
28536
28537 *------------------------------------------------------------------
28538 * initialization
28539     1 CONTINUE
28540       ICEVT = 0
28541       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28542       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28543
28544       RETURN
28545 *------------------------------------------------------------------
28546 * filling of histogram with event-record
28547     2 CONTINUE
28548       ICEVT = ICEVT+1
28549
28550       DO 20 I=1,NHKK
28551          CALL DT_SWPFSP(I,LFSP,LRNL)
28552          IF (LFSP) THEN
28553             IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28554             IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28555          ENDIF
28556          IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28557    20 CONTINUE
28558       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28559
28560       RETURN
28561 *------------------------------------------------------------------
28562 * output
28563     3 CONTINUE
28564       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28565       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28566
28567       RETURN
28568       END
28569
28570 *$ CREATE DT_SWPFSP.FOR
28571 *COPY DT_SWPFSP
28572 *
28573 *===swpfsp=============================================================*
28574 *
28575       SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28576
28577       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28578       SAVE
28579       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28580       PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28581      &           PI   =TWOPI/TWO,
28582      &           BOG  =TWOPI/360.0D0)
28583
28584 * event history
28585
28586       PARAMETER (NMXHKK=200000)
28587
28588       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28589      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28590      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28591
28592 * extended event history
28593       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28594      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28595      &                IHIST(2,NMXHKK)
28596
28597 * particle properties (BAMJET index convention)
28598       CHARACTER*8  ANAME
28599       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28600      &                IICH(210),IIBAR(210),K1(210),K2(210)
28601
28602 * Lorentz-parameters of the current interaction
28603       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28604      &                UMO,PPCM,EPROJ,PPROJ
28605
28606 * flags for input different options
28607       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28608       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28609      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28610
28611 *      INCLUDE '(DIMPAR)'
28612 *     Taken from FLUKA
28613       PARAMETER ( MXXRGN =20000 )
28614       PARAMETER ( MXXMDF =  710 )
28615       PARAMETER ( MXXMDE =  702 )
28616       PARAMETER ( MFSTCK =40000 )
28617       PARAMETER ( MESTCK =  100 )
28618       PARAMETER ( MOSTCK = 2000 )
28619       PARAMETER ( MXPRSN =  100 )
28620       PARAMETER ( MXPDPM =  800 )
28621       PARAMETER ( MXPSCS =30000 )
28622       PARAMETER ( MXGLWN =  300 )
28623       PARAMETER ( MXOUTU =   50 )
28624       PARAMETER ( NALLWP =   64 )
28625       PARAMETER ( NELEMX =   80 )
28626       PARAMETER ( MPDPDX =   18 )
28627       PARAMETER ( MXHTTR =  260 )
28628       PARAMETER ( MXSEAX =   20 )
28629       PARAMETER ( MXHTNC = MXSEAX + 1 )
28630       PARAMETER ( ICOMAX = 2400 )
28631       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
28632       PARAMETER ( NSTBIS =  304 )
28633       PARAMETER ( NQSTIS =   46 )
28634       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
28635       PARAMETER ( MXPABL =  120 )
28636       PARAMETER ( IDMAXP =  450 )
28637       PARAMETER ( IDMXDC = 2000 )
28638       PARAMETER ( MXMCIN =  410 )
28639       PARAMETER ( IHYPMX =    4 )
28640       PARAMETER ( MKBMX1 =   11 )
28641       PARAMETER ( MKBMX2 =   11 )
28642       PARAMETER ( MXIRRD = 2500 )
28643       PARAMETER ( MXTRDC = 1500 )
28644       PARAMETER ( NKTL   =   17 )
28645       PARAMETER ( NBLNMX = 40000000 )
28646
28647 *      INCLUDE '(PAREVT)'
28648 *     Taken from FLUKA
28649       PARAMETER ( FRDIFF = 0.2D+00 )
28650       PARAMETER ( ETHSEA = 1.0D+00 )
28651 *
28652       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28653      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
28654      &        LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
28655      &        LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
28656       COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
28657      &                  LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28658      &                  LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28659      &                  LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
28660      &                  LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
28661      &                  LVP2XX, LV2XNW, LNWV2X, LEVFIN
28662
28663 * temporary storage for one final state particle
28664       LOGICAL LFRAG,LGREY,LBLACK
28665       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28666      &                SINTHE,COSTHE,THETA,THECMS,
28667      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28668      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28669      &                LFRAG,LGREY,LBLACK
28670
28671       LOGICAL LFSP,LRNL
28672
28673       LFSP = .FALSE.
28674       LRNL = .FALSE.
28675       ISTRNL = 1000
28676       MULDEF = 1
28677       IF (LEVPRT) ISTRNL = 1001
28678
28679       IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28680          IST    = ISTHKK(IDX)
28681          IDPDG  = IDHKK(IDX)
28682          LFRAG  = .FALSE.
28683          IF (IDHKK(IDX).LT.80000) THEN
28684             IDBJT  = IDBAM(IDX)
28685             IBARY  = IIBAR(IDBJT)
28686             ICHAR  = IICH(IDBJT)
28687             AMASS  = AAM(IDBJT)
28688          ELSEIF (IDHKK(IDX).EQ.80000) THEN
28689             IDBJT  = 0
28690             IBARY  = IDRES(IDX)
28691             ICHAR  = IDXRES(IDX)
28692             AMASS  = PHKK(5,IDX)
28693             INUT   = IBARY-ICHAR
28694             IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28695             IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28696             IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28697             IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28698             IF (IDBJT.EQ.0) LFRAG = .TRUE.
28699          ELSE
28700             GOTO 9999
28701          ENDIF
28702          PE     = PHKK(4,IDX)
28703          PX     = PHKK(1,IDX)
28704          PY     = PHKK(2,IDX)
28705          PZ     = PHKK(3,IDX)
28706          PT2    = PX**2+PY**2
28707          PT     = SQRT(PT2)
28708          PTOT   = SQRT(PT2+PZ**2)
28709          SINTHE = PT/MAX(PTOT,TINY14)
28710          COSTHE = PZ/MAX(PTOT,TINY14)
28711          IF (COSTHE.GT.ONE) THEN
28712             THETA = ZERO
28713          ELSEIF (COSTHE.LT.-ONE) THEN
28714             THETA = TWOPI/2.0D0
28715          ELSE
28716             THETA = ACOS(COSTHE)
28717          ENDIF
28718          EKIN   = PE-AMASS
28719 **sr 15.4.96 new E_t-definition
28720          IF (IBARY.GT.0) THEN
28721             ET = EKIN*SINTHE
28722          ELSEIF (IBARY.LT.0) THEN
28723             ET = (EKIN+TWO*AMASS)*SINTHE
28724          ELSE
28725             ET = PE*SINTHE
28726          ENDIF
28727 **
28728          XLAB   = PZ/MAX(PPROJ,TINY14)
28729 C        XLAB   = PE/MAX(EPROJ,TINY14)
28730          BETA   = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28731      &                     *(ONE+AMASS/MAX(PE,TINY14)) ))
28732          PPLUS  = PE+PZ
28733          PMINUS = PE-PZ
28734          IF (PMINUS.GT.TINY14) THEN
28735             YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28736          ELSE
28737             YY = 100.0D0
28738          ENDIF
28739          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28740             ETA = -LOG(TAN(THETA/TWO))
28741          ELSE
28742             ETA = 100.0D0
28743          ENDIF
28744          IF (IFRAME.EQ.1) THEN
28745             CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28746             PPLUS  = EECMS+PZCMS
28747             PMINUS = EECMS-PZCMS
28748             IF ((PPLUS*PMINUS).GT.TINY14) THEN
28749                YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28750             ELSE
28751                YYCMS = 100.0D0
28752             ENDIF
28753             PTOTCM = SQRT(PT2+PZCMS**2)
28754             COSTH = PZCMS/MAX(PTOTCM,TINY14)
28755             IF (COSTH.GT.ONE) THEN
28756                THECMS = ZERO
28757             ELSEIF (COSTH.LT.-ONE) THEN
28758                THECMS = TWOPI/2.0D0
28759             ELSE
28760                THECMS = ACOS(COSTH)
28761             ENDIF
28762             IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28763                ETACMS = -LOG(TAN(THECMS/TWO))
28764             ELSE
28765                ETACMS = 100.0D0
28766             ENDIF
28767             XF = PZCMS/MAX(PPCM,TINY14)
28768             THECMS = THECMS/BOG
28769          ELSE
28770             PZCMS  = PZ
28771             EECMS  = PE
28772             YYCMS  = YY
28773             ETACMS = ETA
28774             XF     = XLAB
28775             THECMS = THETA/BOG
28776          ENDIF
28777          THETA  = THETA/BOG
28778
28779 * set flag for "grey/black"
28780          LGREY  = .FALSE.
28781          LBLACK = .FALSE.
28782          EK     = EKIN
28783          IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28784          IF (MULDEF.EQ.1) THEN
28785 *  EMU01-Def.
28786             IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28787      &                              (EK.LE.375.0D-3)      ).OR.
28788      &           ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28789      &                              (EK.LE. 56.0D-3)      ).OR.
28790      &           ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28791      &                              (EK.LE. 56.0D-3)      ).OR.
28792      &           ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28793      &                              (EK.LE.198.0D-3)      ).OR.
28794      &           ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28795      &                              (EK.LE.198.0D-3)      ).OR.
28796      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28797      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28798      &             (IDBJT.NE.16).AND.
28799      &             (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)    ) )
28800      &         LGREY = .TRUE.
28801             IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28802      &           ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28803      &           ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28804      &           ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28805      &           ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28806      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28807      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28808      &             (IDBJT.NE.16).AND.(BETA.LE.0.23D0)  ) )
28809      &         LBLACK = .TRUE.
28810          ELSE
28811 *  common Def.
28812             IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28813             IF (BETA.LE.0.23D0) LBLACK=.TRUE.
28814          ENDIF
28815          LFSP = .TRUE.
28816       ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
28817          IST    = ISTHKK(IDX)
28818          IDPDG  = IDHKK(IDX)
28819          LFRAG  = .TRUE.
28820          IDBJT  = 0
28821          IBARY  = IDRES(IDX)
28822          ICHAR  = IDXRES(IDX)
28823          AMASS  = PHKK(5,IDX)
28824          PE     = PHKK(4,IDX)
28825          PX     = PHKK(1,IDX)
28826          PY     = PHKK(2,IDX)
28827          PZ     = PHKK(3,IDX)
28828          PT2    = PX**2+PY**2
28829          PT     = SQRT(PT2)
28830          PTOT   = SQRT(PT2+PZ**2)
28831          SINTHE = PT/MAX(PTOT,TINY14)
28832          COSTHE = PZ/MAX(PTOT,TINY14)
28833          IF (COSTHE.GT.ONE) THEN
28834             THETA = ZERO
28835          ELSEIF (COSTHE.LT.-ONE) THEN
28836             THETA = TWOPI/2.0D0
28837          ELSE
28838             THETA  = ACOS(COSTHE)
28839          ENDIF
28840          EKIN   = PE-AMASS
28841 **sr 15.4.96 new E_t-definition
28842 C        ET     = PE*SINTHE
28843          ET     = EKIN*SINTHE
28844 **
28845          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28846             ETA = -LOG(TAN(THETA/TWO))
28847          ELSE
28848             ETA = 100.0D0
28849          ENDIF
28850          THETA  = THETA/BOG
28851          LRNL   = .TRUE.
28852       ENDIF
28853
28854  9999 CONTINUE
28855       RETURN
28856       END
28857
28858 *$ CREATE DT_HIMULT.FOR
28859 *COPY DT_HIMULT
28860 *
28861 *===himult=============================================================*
28862 *
28863       SUBROUTINE DT_HIMULT(MODE)
28864
28865 ************************************************************************
28866 * Tables of average energies/multiplicities.                           *
28867 * This version dated 30.08.2000 is written by S. Roesler               *
28868 ************************************************************************
28869
28870       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28871       SAVE
28872
28873       PARAMETER ( LINP = 10 ,
28874      &            LOUT = 6 ,
28875      &            LDAT = 9 )
28876
28877       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28878
28879       PARAMETER (SWMEXP=1.7D0)
28880
28881       CHARACTER*8 ANAMEH(4)
28882
28883 * particle properties (BAMJET index convention)
28884       CHARACTER*8  ANAME
28885       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28886      &                IICH(210),IIBAR(210),K1(210),K2(210)
28887
28888 * temporary storage for one final state particle
28889       LOGICAL LFRAG,LGREY,LBLACK
28890       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28891      &                SINTHE,COSTHE,THETA,THECMS,
28892      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28893      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28894      &                LFRAG,LGREY,LBLACK
28895
28896 * event flag used for histograms
28897       COMMON /DTNORM/ ICEVT,IEVHKK
28898
28899 * Lorentz-parameters of the current interaction
28900       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28901      &                UMO,PPCM,EPROJ,PPROJ
28902
28903       PARAMETER (NOPART=210)
28904       DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
28905      &          AVPT(4,NOPART),IAVPT(4,NOPART)
28906       DATA ANAMEH /'DEUTERON','3-H     ','3-HE    ','4-HE    '/
28907
28908       GOTO (1,2,3) MODE
28909
28910 *------------------------------------------------------------------
28911 * initialization
28912     1 CONTINUE
28913       DO 10 I=1,NOPART
28914          DO 11 J=1,4
28915             AVMULT(J,I) = ZERO
28916             AVE(J,I)    = ZERO
28917             AVSWM(J,I)  = ZERO
28918             AVPT(J,I)   = ZERO
28919             IAVPT(J,I)  = 0
28920    11    CONTINUE
28921    10 CONTINUE
28922
28923       RETURN
28924
28925 *------------------------------------------------------------------
28926 * filling of histogram with event-record
28927     2 CONTINUE
28928       IF (PE.LT.0.0D0) THEN
28929          WRITE(LOUT,*) ' HIMULT:  PE < 0 ! ',PE
28930          RETURN
28931       ENDIF
28932       IF (.NOT.LFRAG) THEN
28933          IVEL = 2
28934          IF (LGREY)  IVEL = 3
28935          IF (LBLACK) IVEL = 4
28936          AVE(1,IDBJT)       = AVE(1,IDBJT)   +PE
28937          AVE(IVEL,IDBJT)    = AVE(IVEL,IDBJT)+PE
28938          AVPT(1,IDBJT)     = AVPT(1,IDBJT)   +PT
28939          AVPT(IVEL,IDBJT)  = AVPT(IVEL,IDBJT)+PT
28940          IAVPT(1,IDBJT)    = IAVPT(1,IDBJT)   +1
28941          IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
28942          AVSWM(1,IDBJT)     = AVSWM(1,IDBJT)   +PE**SWMEXP
28943          AVSWM(IVEL,IDBJT)  = AVSWM(IVEL,IDBJT)+PE**SWMEXP
28944          AVMULT(1,IDBJT)    = AVMULT(1,IDBJT)   +ONE
28945          AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
28946          IF (IDBJT.LT.116) THEN
28947 *   total energy, multiplicity
28948             AVE(1,30)       = AVE(1,30)   +PE
28949             AVE(IVEL,30)    = AVE(IVEL,30)+PE
28950             AVPT(1,30)     = AVPT(1,30)   +PT
28951             AVPT(IVEL,30)  = AVPT(IVEL,30)+PT
28952             IAVPT(1,30)    = IAVPT(1,30)   +1
28953             IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
28954             AVSWM(1,30)     = AVSWM(1,30)+PE**SWMEXP
28955             AVSWM(IVEL,30)  = AVSWM(IVEL,30)+PE**SWMEXP
28956             AVMULT(1,30)    = AVMULT(1,30)   +ONE
28957             AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
28958 *   charged energy, multiplicity
28959             IF (ICHAR.LT.0) THEN
28960                AVE(1,26)       = AVE(1,26)   +PE
28961                AVE(IVEL,26)    = AVE(IVEL,26)+PE
28962                AVPT(1,26)     = AVPT(1,26)   +PT
28963                AVPT(IVEL,26)  = AVPT(IVEL,26)+PT
28964                IAVPT(1,26)    = IAVPT(1,26)   +1
28965                IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
28966                AVSWM(1,26)     = AVSWM(1,26)   +PE**SWMEXP
28967                AVSWM(IVEL,26)  = AVSWM(IVEL,26)+PE**SWMEXP
28968                AVMULT(1,26)    = AVMULT(1,26)   +ONE
28969                AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
28970             ENDIF
28971             IF (ICHAR.NE.0) THEN
28972                AVE(1,27)       = AVE(1,27)   +PE
28973                AVE(IVEL,27)    = AVE(IVEL,27)+PE
28974                AVPT(1,27)     = AVPT(1,27)   +PT
28975                AVPT(IVEL,27)  = AVPT(IVEL,27)+PT
28976                IAVPT(1,27)    = IAVPT(1,27)   +1
28977                IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
28978                AVSWM(1,27)     = AVSWM(1,27)   +PE**SWMEXP
28979                AVSWM(IVEL,27)  = AVSWM(IVEL,27)+PE**SWMEXP
28980                AVMULT(1,27)    = AVMULT(1,27)   +ONE
28981                AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
28982             ENDIF
28983          ENDIF
28984       ENDIF
28985
28986       RETURN
28987
28988 *------------------------------------------------------------------
28989 * output
28990     3 CONTINUE
28991       WRITE(LOUT,3000)
28992  3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
28993      &       29X,'---------------------',/)
28994       IF (MULDEF.EQ.1) THEN
28995          WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
28996       ELSE
28997          BETGRE = 0.7D0
28998          BETBLC = 0.23D0
28999          WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
29000  3002    FORMAT(1X,'fast:  beta > ',F4.2,'    grey:  ',F4.2,' > beta > '
29001      &          ,F4.2,'    black:  beta < ',F4.2,/)
29002       ENDIF
29003       WRITE(LOUT,3003) SWMEXP
29004  3003 FORMAT(1X,'particle    |',12X,'average multiplicity',/,
29005      &      13X,'|     total         fast',
29006 C    &      '       grey     black      K      f(',F3.1,')',/,1X,
29007      &      '       grey     black    <pt>     f(',F3.1,')',/,1X,
29008      &      '------------+--------------',
29009      &      '-------------------------------------------------')
29010       DO 30 I=1,NOPART
29011          DO 31 J=1,4
29012             AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29013             AVE(J,I)    = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29014             AVPT(J,I)   = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29015             AVSWM(J,I)  = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29016    31    CONTINUE
29017          IF (I.LE.115) THEN
29018             WRITE(LOUT,3004) ANAME(I),I,
29019      &                       AVMULT(1,I),AVMULT(2,I),
29020      &                       AVMULT(3,I),AVMULT(4,I),
29021 C    &                       AVE(1,I),AVSWM(1,I)
29022      &                       AVPT(1,I),AVSWM(1,I)
29023          ELSEIF (I.LE.119) THEN
29024             WRITE(LOUT,3004) ANAMEH(I-115),I,
29025      &                       AVMULT(1,I),AVMULT(2,I),
29026      &                       AVMULT(3,I),AVMULT(4,I),
29027 C    &                       AVE(1,I),AVSWM(1,I)
29028      &                       AVPT(1,I),AVSWM(1,I)
29029          ENDIF
29030  3004    FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29031    30 CONTINUE
29032 **temporary
29033 C     WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29034 C    &               AVMULT(3,27)+AVMULT(4,27)
29035 **
29036
29037       RETURN
29038       END
29039
29040 *$ CREATE DT_HISTAT.FOR
29041 *COPY DT_HISTAT
29042 *
29043 *===histat=============================================================*
29044 *
29045       SUBROUTINE DT_HISTAT(IDX,MODE)
29046
29047 ************************************************************************
29048 * This version dated 26.02.96 is written by S. Roesler                 *
29049 *                                                                      *
29050 * Last change 27.12.2006 by S. Roesler.                                *
29051 ************************************************************************
29052
29053       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29054       SAVE
29055
29056       PARAMETER ( LINP = 10 ,
29057      &            LOUT = 6 ,
29058      &            LDAT = 9 )
29059
29060       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29061       PARAMETER (NDIM=199)
29062
29063 * event history
29064
29065       PARAMETER (NMXHKK=200000)
29066
29067       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29068      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29069      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29070
29071 * extended event history
29072       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29073      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29074      &                IHIST(2,NMXHKK)
29075
29076 * particle properties (BAMJET index convention)
29077       CHARACTER*8  ANAME
29078       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29079      &                IICH(210),IIBAR(210),K1(210),K2(210)
29080
29081       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29082
29083 * Glauber formalism: cross sections
29084       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29085      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29086      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29087      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29088      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29089      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29090      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29091      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29092      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29093      &                BSLOPE,NEBINI,NQBINI
29094
29095 * emulsion treatment
29096       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29097      &                NCOMPO,IEMUL
29098
29099 * properties of interacting particles
29100       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29101
29102 * rejection counter
29103       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29104      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29105      &                IREXCI(3),IRDIFF(2),IRINC
29106
29107 * statistics: residual nuclei
29108       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29109      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29110      &                NINCST(2,4),NINCEV(2),
29111      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29112      &                NRESPB(2),NRESCH(2),NRESEV(4),
29113      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29114      &                NEVAFI(2,2)
29115
29116 * parameter for intranuclear cascade
29117       LOGICAL LPAULI
29118       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29119
29120 *      INCLUDE '(DIMPAR)'
29121 *     Taken from FLUKA
29122       PARAMETER ( MXXRGN =20000 )
29123       PARAMETER ( MXXMDF =  710 )
29124       PARAMETER ( MXXMDE =  702 )
29125       PARAMETER ( MFSTCK =40000 )
29126       PARAMETER ( MESTCK =  100 )
29127       PARAMETER ( MOSTCK = 2000 )
29128       PARAMETER ( MXPRSN =  100 )
29129       PARAMETER ( MXPDPM =  800 )
29130       PARAMETER ( MXPSCS =30000 )
29131       PARAMETER ( MXGLWN =  300 )
29132       PARAMETER ( MXOUTU =   50 )
29133       PARAMETER ( NALLWP =   64 )
29134       PARAMETER ( NELEMX =   80 )
29135       PARAMETER ( MPDPDX =   18 )
29136       PARAMETER ( MXHTTR =  260 )
29137       PARAMETER ( MXSEAX =   20 )
29138       PARAMETER ( MXHTNC = MXSEAX + 1 )
29139       PARAMETER ( ICOMAX = 2400 )
29140       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
29141       PARAMETER ( NSTBIS =  304 )
29142       PARAMETER ( NQSTIS =   46 )
29143       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
29144       PARAMETER ( MXPABL =  120 )
29145       PARAMETER ( IDMAXP =  450 )
29146       PARAMETER ( IDMXDC = 2000 )
29147       PARAMETER ( MXMCIN =  410 )
29148       PARAMETER ( IHYPMX =    4 )
29149       PARAMETER ( MKBMX1 =   11 )
29150       PARAMETER ( MKBMX2 =   11 )
29151       PARAMETER ( MXIRRD = 2500 )
29152       PARAMETER ( MXTRDC = 1500 )
29153       PARAMETER ( NKTL   =   17 )
29154       PARAMETER ( NBLNMX = 40000000 )
29155
29156 *      INCLUDE '(PAREVT)'
29157 *     Taken from FLUKA
29158       PARAMETER ( FRDIFF = 0.2D+00 )
29159       PARAMETER ( ETHSEA = 1.0D+00 )
29160 *
29161       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29162      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
29163      &        LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
29164      &        LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
29165       COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
29166      &                  LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29167      &                  LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29168      &                  LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
29169      &                  LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
29170      &                  LVP2XX, LV2XNW, LNWV2X, LEVFIN
29171
29172 *      INCLUDE '(FRBKCM)'
29173 *     Taken from FLUKA
29174 *  Maximum number of fragments to be emitted:
29175       PARAMETER ( MXFFBK =     6 )
29176       PARAMETER ( MXZFBK =    10 )
29177       PARAMETER ( MXNFBK =    12 )
29178       PARAMETER ( MXAFBK =    16 )
29179       PARAMETER ( MXASST =    25 )
29180       PARAMETER ( NXAFBK = MXAFBK + 1 )
29181       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
29182       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
29183       PARAMETER ( MXPSST =   700 )
29184 *  Maximum number of pre-computed break-up combinations
29185       PARAMETER ( MXPPFB = 42500 )
29186 *  Maximum number of break-up combinations, including special
29187 *  run-time ones:
29188       PARAMETER ( MXPSFB = 43000 )
29189 *  Base for J multiplicity encoding:
29190       PARAMETER ( IBFRBK =    73 )
29191 *  Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
29192 *  it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
29193 *  ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
29194 *  --> Ibfrbk^(Jpwfbx+1) < 2100000000
29195       PARAMETER ( JPWFBX =     4 )
29196       LOGICAL LFRMBK, LNCMSS
29197       COMMON / FRBKCM /  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29198      &          WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
29199      &          SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
29200      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
29201      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
29202      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29203      &          IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
29204      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29205      &          IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
29206      &          IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
29207
29208 *      INCLUDE '(EVAFLG)'
29209 *     Taken from FLUKA
29210       LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29211      &        LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29212      &        LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29213      &        LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29214       COMMON / EVAFLG /     BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
29215      &        ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
29216      &        MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
29217      &        MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
29218      &        LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29219      &        LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29220      &        LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29221      &        LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29222
29223 * temporary storage for one final state particle
29224       LOGICAL LFRAG,LGREY,LBLACK
29225       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29226      &                SINTHE,COSTHE,THETA,THECMS,
29227      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29228      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29229      &                LFRAG,LGREY,LBLACK
29230
29231 * event flag used for histograms
29232       COMMON /DTNORM/ ICEVT,IEVHKK
29233
29234 * statistics: double-Pomeron exchange
29235       COMMON /DTFLG2/ INTFLG,IPOPO
29236
29237       DIMENSION EMUSAM(NCOMPX)
29238
29239       CHARACTER*13 CMSG(3)
29240       DATA CMSG /'not requested','not requested','not requested'/
29241
29242       GOTO (1,2,3,4,5) MODE
29243
29244 *------------------------------------------------------------------
29245 * initialization
29246     1 CONTINUE
29247 *  emulsion treatment
29248       IF (NCOMPO.GT.0) THEN
29249          DO 10 I=1,NCOMPX
29250             EMUSAM(I) = ZERO
29251    10    CONTINUE
29252       ENDIF
29253 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29254       NINCGE = 0
29255       DO 11 I=1,2
29256          EXCDPM(I)   = ZERO
29257          EXCDPM(I+2) = ZERO
29258          EXCEVA(I)   = ZERO
29259          NINCWO(I)   = 0
29260          NINCEV(I)   = 0
29261          NRESTO(I)   = 0
29262          NRESPR(I)   = 0
29263          NRESNU(I)   = 0
29264          NRESBA(I)   = 0
29265          NRESPB(I)   = 0
29266          NRESCH(I)   = 0
29267          NRESEV(I)   = 0
29268          NRESEV(I+2) = 0
29269          NEVAGA(I)   = 0
29270          NEVAHT(I)   = 0
29271          NEVAFI(1,I) = 0
29272          NEVAFI(2,I) = 0
29273          DO 12 J=1,6
29274             IF (J.LE.2) NINCHR(I,J) = 0
29275             IF (J.LE.3) NINCCO(I,J) = 0
29276             IF (J.LE.4) NINCST(I,J) = 0
29277             NEVA(I,J) = 0
29278    12    CONTINUE
29279          DO 13 J=1,210
29280             NEVAHY(1,I,J) = 0
29281             NEVAHY(2,I,J) = 0
29282    13    CONTINUE
29283    11 CONTINUE
29284       MAXGEN = 0
29285 **dble Po statistics.
29286       KPOPO = 0
29287
29288       RETURN
29289 *------------------------------------------------------------------
29290 * filling of histogram with event-record
29291     2 CONTINUE
29292       IF (IST.EQ.-1) THEN
29293          IF (.NOT.LFRAG) THEN
29294             IF (IDPDG.EQ.2212) THEN
29295                NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29296             ELSEIF (IDPDG.EQ.2112) THEN
29297                NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29298             ELSEIF (IDPDG.EQ.22) THEN
29299                NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29300             ELSEIF (IDPDG.EQ.80000) THEN
29301                IF (IDBJT.EQ.116) THEN
29302                   NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29303                ELSEIF (IDBJT.EQ.117) THEN
29304                   NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29305                ELSEIF (IDBJT.EQ.118) THEN
29306                   NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29307                ELSEIF (IDBJT.EQ.119) THEN
29308                   NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29309                ENDIF
29310             ENDIF
29311          ELSE
29312 *   heavy fragments (here: fission products only)
29313             NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29314             NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29315             NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29316          ENDIF
29317       ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29318          IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29319       ENDIF
29320
29321       RETURN
29322 *------------------------------------------------------------------
29323 * output
29324     3 CONTINUE
29325
29326 **dble Po statistics.
29327 C     WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29328 C    &   '# evts. / # dble-Po. evts / s_in / s_popo :',
29329 C    & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29330
29331 *  emulsion treatment
29332       IF (NCOMPO.GT.0) THEN
29333          WRITE(LOUT,3000)
29334  3000    FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29335      &          22X,'----------------------------',/,/,19X,
29336      &          'mass    charge          fraction',/,39X,
29337      &          'input     treated',/)
29338          DO 30 I=1,NCOMPO
29339             WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29340      &                       EMUSAM(I)/DBLE(ICEVT)
29341  3013       FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29342    30    CONTINUE
29343       ENDIF
29344
29345 *  i.n.c. statistics: output
29346       WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29347  3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29348      &       22X,'---------------------------------',/,/,1X,
29349      &       'no. of events for normalization: (accepted final events,',
29350      &       ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29351      &       /,1X,'no. of rejected events due to intranuclear',
29352      &       ' cascade',15X,I6,/)
29353       ICEV  = MAX(ICEVT,1)
29354       ICEV1 = ICEV
29355       IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29356       WRITE(LOUT,3002)
29357      &     (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29358      &     ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29359      &     KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29360      &    (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29361      &     (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29362      &     (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29363      &     (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29364  3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29365      &       5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29366      &       ' proj./ target (mean per evt)',/,8X,'baryons:  pos. ',
29367      &       F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,/,8X,
29368      &       'mesons:   pos. ',F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,
29369      &       /,1X,'maximum no. of generations treated (maximum allowed:'
29370      &       ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29371      &       ' interactions in proj./ target (mean per evt1)',
29372      &       F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29373      &       ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29374      &       'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29375      &       '(ap, K-, pi- only)     ',F7.3,' /',F7.3,/)
29376       WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29377      &                 IREXCI(1)+IREXCI(2)+IREXCI(3)
29378  3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29379      &       'evaporation',/,22X,'-----------------------------',
29380      &       '------------',/,/,1X,'no. of events for normal.: ',
29381      &       '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29382      &       ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29383      &       ' rejected events     (',I4,',',I4,',',I4,')',22X,I6,/)
29384
29385       WRITE(LOUT,3004)
29386  3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29387       ICEV  = MAX(NRESEV(2),1)
29388       WRITE(LOUT,3005)
29389      &     (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29390      &     (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29391      &     (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29392      &     (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29393      &     (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29394      &     (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29395      &     (EXCDPM(I)/DBLE(ICEV),I=1,2),
29396      &     (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29397  3005    FORMAT(1X,'residual nuclei:  (mean values per evt)',12X,
29398      &       'proj. / target',/,/,8X,'total number of particles',15X,
29399      &       2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29400      &       'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29401      &       'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29402      &       /,8X,'excitation energy (bef. evap.-step)   ',2E11.3,/,
29403      &       8X,'excitation energy per nucleon         ',2E11.3,/,/)
29404
29405 * evaporation / fission / fragmentation statistics: output
29406       ICEV  = MAX(NRESEV(2),1)
29407       ICEV1 = MAX(NRESEV(4),1)
29408       NTEVA1 =
29409      &   NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29410       NTEVA2 =
29411      &   NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29412       IF (LEVPRT) THEN
29413
29414          IF (IEVFSS.EQ.1) CMSG(1) = 'requested    '
29415
29416          IF (LFRMBK)     CMSG(2) = 'requested    '
29417          IF (LDEEXG)     CMSG(3) = 'requested    '
29418          WRITE(LOUT,3006)
29419      &        CMSG,
29420      &        DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29421      &        (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29422      &        (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29423      &        (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29424      &        (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29425      &        (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29426      &        (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29427      &        (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29428      &        (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29429  3006    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,'Fission:',
29430      &       13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29431      &       'deexcitation:',2X,A13,/,/,
29432      &       1X,'evaporation/deexcitation:  (mean values per evt1)  ',
29433      &       'proj. / target',/,/,8X,'total number of evap. particles',
29434      &       9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29435      &       'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29436      &       '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29437      &       2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29438      &       'heavy fragments',25X,2F9.3,/)
29439
29440          IF (IEVFSS.EQ.1) THEN
29441
29442             WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29443      &                       NEVAFI(2,1),NEVAFI(2,2),
29444      &             DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29445      &             DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29446  3007       FORMAT(1X,'Fission:   total number of events',14X,2I9,/
29447      &             12X,'out of which fission occured',8X,2I9,/,
29448      &             50X,'(',F5.2,'%) (',F5.2,'%)',/)
29449          ENDIF
29450
29451 C        IF ((LFRMBK).OR.(IEVFSS.EQ.1)) THEN
29452
29453 C           WRITE(LOUT,3008)
29454 C3008       FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29455 C    &             '       proj.   / target',/)
29456 C           DO 31 I=1,210
29457 C              IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29458 C                 WRITE(LOUT,3009) I,
29459 C    &            (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29460 C3009             FORMAT(38X,I3,3X,2E12.3)
29461 C              ENDIF
29462 C  31       CONTINUE
29463 C           WRITE(LOUT,3010)
29464 C3010       FORMAT(1X,'heavy fragments - statistics:',7X,'mass  ',
29465 C    &             '       proj.   / target',/)
29466 C           DO 32 I=1,210
29467 C              IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29468 C                 WRITE(LOUT,3011) I,
29469 C    &            (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29470 C3011             FORMAT(38X,I3,3X,2E12.3)
29471 C              ENDIF
29472 C  32       CONTINUE
29473 C           WRITE(LOUT,*)
29474 C        ENDIF
29475       ELSE
29476          WRITE(LOUT,3012)
29477  3012    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,
29478      &       'Evaporation:         not requested',/)
29479       ENDIF
29480
29481       RETURN
29482 *------------------------------------------------------------------
29483 * filling of histogram with event-record
29484     4 CONTINUE
29485 *  emulsion treatment
29486       IF (NCOMPO.GT.0) THEN
29487          DO 40 I=1,NCOMPO
29488             IF (IT.EQ.IEMUMA(I)) THEN
29489                EMUSAM(I) = EMUSAM(I)+ONE
29490             ENDIF
29491    40    CONTINUE
29492       ENDIF
29493       NINCGE = NINCGE+MAXGEN
29494       MAXGEN = 0
29495 **dble Po statistics.
29496       IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29497
29498       RETURN
29499 *------------------------------------------------------------------
29500 * filling of histogram with event-record
29501     5 CONTINUE
29502       IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29503          IB = IIBAR(IDBAM(IDX))
29504          IC = IICH(IDBAM(IDX))
29505          J  = ISTHKK(IDX)-14
29506          IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29507             NINCST(J,1) = NINCST(J,1)+1
29508          ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29509             NINCST(J,2) = NINCST(J,2)+1
29510          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29511             NINCST(J,3) = NINCST(J,3)+1
29512          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29513             NINCST(J,4) = NINCST(J,4)+1
29514          ENDIF
29515       ELSEIF (ISTHKK(IDX).EQ.17) THEN
29516          NINCWO(1) = NINCWO(1)+1
29517       ELSEIF (ISTHKK(IDX).EQ.18) THEN
29518          NINCWO(2) = NINCWO(2)+1
29519       ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29520          IB = IDRES(IDX)
29521          IC = IDXRES(IDX)
29522          IF (IC.GT.0) THEN
29523             NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29524             NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29525          ENDIF
29526          NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29527       ENDIF
29528
29529       RETURN
29530       END
29531 *$ CREATE DT_NEWHGR.FOR
29532 *COPY DT_NEWHGR
29533 *
29534 *===newhgr=============================================================*
29535 *
29536       SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29537
29538 ************************************************************************
29539 *                                                                      *
29540 *     Histogram initialization.                                        *
29541 *                                                                      *
29542 *     input:  XLIM1/XLIM2  lower/upper edge of histogram-window        *
29543 *             XLIM3        bin size                                    *
29544 *             IBIN    > 0  number of bins in equidistant lin. binning  *
29545 *                     = -1 reset histograms                            *
29546 *                     < -1 |IBIN| number of bins in equidistant log.   *
29547 *                          binning or log. binning in user def. struc. *
29548 *             XLIMB(*)     user defined bin structure                  *
29549 *                                                                      *
29550 *     The bin structure is sensitive to                                *
29551 *             XLIM1, XLIM3, IBIN     if     XLIM3 > 0   (lin.)         *
29552 *             XLIM1, XLIM2, IBIN     if     XLIM3 = 0   (lin. & log.)  *
29553 *             XLIMB, IBIN            if     XLIM3 < 0                  *
29554 *                                                                      *
29555 *                                                                      *
29556 *     output: IREFN        histogram index                             *
29557 *                          (= -1 for inconsistent histogr. request)    *
29558 *                                                                      *
29559 * This subroutine is based on a original version by R. Engel.          *
29560 * This version dated 22.4.95 is written  by S. Roesler.                *
29561 ************************************************************************
29562
29563       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29564       SAVE
29565
29566       PARAMETER ( LINP = 10 ,
29567      &            LOUT = 6 ,
29568      &            LDAT = 9 )
29569
29570       LOGICAL LSTART
29571
29572       PARAMETER (ZERO   =  0.0D0,
29573      &           TINY   =  1.0D-10)
29574
29575       DIMENSION XLIMB(*)
29576
29577 * histograms
29578
29579       PARAMETER (NHIS=150, NDIM=250)
29580
29581       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29582      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29583
29584 * auxiliary common for histograms
29585       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29586
29587       DATA LSTART /.TRUE./
29588
29589 * reset histogram counter
29590       IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29591          IHISL  = 0
29592          IF (IBIN.EQ.-1) RETURN
29593          LSTART = .FALSE.
29594       ENDIF
29595
29596       IHIS  = IHISL+1
29597 * check for maximum number of allowed histograms
29598       IF (IHIS.GT.NHIS) THEN
29599          WRITE(LOUT,1003) IHIS,NHIS,IHIS
29600  1003    FORMAT(1X,'NEWHGR:   warning!  number of histograms (',
29601      &          I4,') exceeds array size (',I4,')',/,21X,
29602      &          'histogram',I3,' skipped!')
29603          GOTO 9999
29604       ENDIF
29605
29606       IREFN = IHIS
29607       IBINS(IHIS) = ABS(IBIN)
29608 * check requested number of bins
29609       IF (IBINS(IHIS).GE.NDIM) THEN
29610          WRITE(LOUT,1000) IBIN,NDIM,NDIM
29611  1000    FORMAT(1X,'NEWHGR:   warning!  number of bins (',
29612      &          I3,') exceeds array size (',I3,')',/,21X,
29613      &          'and will be reset to ',I3)
29614          IBINS(IHIS) = NDIM
29615       ENDIF
29616       IF (IBINS(IHIS).EQ.0) THEN
29617          WRITE(LOUT,1001) IBIN,IHIS
29618  1001    FORMAT(1X,'NEWHGR:   warning!  inconsistent number of',
29619      &          ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29620          GOTO 9999
29621       ENDIF
29622
29623 * initialize arrays
29624       DO 1 I=1,NDIM
29625          DO 2 K=1,3
29626             HIST(K,IHIS,I)   = ZERO
29627             HIST(K+3,IHIS,I) = ZERO
29628             TMPHIS(K,IHIS,I) = ZERO
29629     2    CONTINUE
29630          HIST(7,IHIS,I)   = ZERO
29631     1 CONTINUE
29632       DENTRY(1,IHIS)= ZERO
29633       DENTRY(2,IHIS)= ZERO
29634       OVERF(IHIS)   = ZERO
29635       UNDERF(IHIS)  = ZERO
29636       TMPUFL(IHIS)  = ZERO
29637       TMPOFL(IHIS)  = ZERO
29638
29639 * bin str. sensitive to lower edge, bin size, and numb. of bins
29640       IF (XLIM3.GT.ZERO) THEN
29641          DO 3 K=1,IBINS(IHIS)+1
29642             HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29643     3    CONTINUE
29644          ISWI(IHIS) = 1
29645 * bin str. sensitive to lower/upper edge and numb. of bins
29646       ELSEIF (XLIM3.EQ.ZERO) THEN
29647 *   linear binning
29648          IF (IBIN.GT.0) THEN
29649             XLOW = XLIM1
29650             XHI  = XLIM2
29651             IF (XLIM2.LE.XLIM1) THEN
29652                WRITE(LOUT,1002) XLIM1,XLIM2
29653  1002          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29654      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29655                GOTO 9999
29656             ENDIF
29657             ISWI(IHIS) = 1
29658          ELSEIF (IBIN.LT.-1) THEN
29659 *   logarithmic binning
29660             IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29661                WRITE(LOUT,1004) XLIM1,XLIM2
29662  1004          FORMAT(1X,'NEWHGR:   warning!  inconsistent log. ',
29663      &                'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29664                GOTO 9999
29665             ENDIF
29666             IF (XLIM2.LE.XLIM1) THEN
29667                WRITE(LOUT,1005) XLIM1,XLIM2
29668  1005          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29669      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29670                GOTO 9999
29671             ENDIF
29672             XLOW = LOG10(XLIM1)
29673             XHI  = LOG10(XLIM2)
29674             ISWI(IHIS) = 3
29675          ENDIF
29676          DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29677          DO 4 K=1,IBINS(IHIS)+1
29678             HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29679     4    CONTINUE
29680       ELSE
29681 * user defined bin structure
29682          DO 5 K=1,IBINS(IHIS)+1
29683             IF (IBIN.GT.0) THEN
29684                HIST(1,IHIS,K) = XLIMB(K)
29685                ISWI(IHIS) = 2
29686             ELSEIF (IBIN.LT.-1) THEN
29687                HIST(1,IHIS,K) = LOG10(XLIMB(K))
29688                ISWI(IHIS) = 4
29689             ENDIF
29690     5    CONTINUE
29691       ENDIF
29692
29693 * histogram accepted
29694       IHISL = IHIS
29695
29696       RETURN
29697
29698  9999 CONTINUE
29699       IREFN = -1
29700       RETURN
29701       END
29702
29703 *$ CREATE DT_FILHGR.FOR
29704 *COPY DT_FILHGR
29705 *
29706 *===filhgr=============================================================*
29707 *
29708       SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29709
29710 ************************************************************************
29711 *                                                                      *
29712 *     Scoring for histogram IHIS.                                      *
29713 *                                                                      *
29714 * This subroutine is based on a original version by R. Engel.          *
29715 * This version dated 23.4.95 is written  by S. Roesler.                *
29716 ************************************************************************
29717
29718       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29719       SAVE
29720
29721       PARAMETER ( LINP = 10 ,
29722      &            LOUT = 6 ,
29723      &            LDAT = 9 )
29724
29725       PARAMETER (ZERO = 0.0D0,
29726      &           ONE  = 1.0D0,
29727      &           TINY = 1.0D-10)
29728
29729 * histograms
29730
29731       PARAMETER (NHIS=150, NDIM=250)
29732
29733       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29734      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29735
29736 * auxiliary common for histograms
29737       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29738
29739       DATA NCEVT /1/
29740
29741       X = XI
29742       Y = YI
29743
29744 * dump content of temorary arrays into histograms
29745       IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29746          CALL DT_EVTHIS(IDUM)
29747          NCEVT = NEVT
29748       ENDIF
29749
29750 * check histogram index
29751       IF (IHIS.EQ.-1) RETURN
29752       IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29753 C        WRITE(LOUT,1000) IHIS,IHISL
29754  1000    FORMAT(1X,'FILHGR:   warning!  histogram index',I4,
29755      &          ' out of range (1..',I3,')')
29756          RETURN
29757       ENDIF
29758
29759       IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29760 * bin structure not explicitly given
29761          IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29762          DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29763          IF (X.LT.HIST(1,IHIS,1)) THEN
29764             I1 = 0
29765          ELSE
29766             I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29767          ENDIF
29768
29769       ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29770 * user defined bin structure
29771          IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29772          IF (X.LT.HIST(1,IHIS,1)) THEN
29773             I1 = 0
29774          ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29775             I1 = IBINS(IHIS)+1
29776          ELSE
29777 *   binary sort algorithm
29778             KMIN = 0
29779             KMAX = IBINS(IHIS)+1
29780     1       CONTINUE
29781             IF ((KMAX-KMIN).EQ.1) GOTO 2
29782             KK = (KMAX+KMIN)/2
29783             IF (X.LE.HIST(1,IHIS,KK)) THEN
29784                KMAX=KK
29785             ELSE
29786                KMIN=KK
29787             ENDIF
29788             GOTO 1
29789     2       CONTINUE
29790             I1 = KMIN
29791          ENDIF
29792
29793       ELSE
29794          WRITE(LOUT,1001)
29795  1001    FORMAT(1X,'FILHGR:   warning!  histogram not initialized')
29796          RETURN
29797       ENDIF
29798
29799 * scoring
29800       IF (I1.LE.0) THEN
29801          TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29802       ELSEIF (I1.LE.IBINS(IHIS)) THEN
29803          TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29804          IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29805             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29806          ELSE
29807             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29808          ENDIF
29809          TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29810       ELSE
29811          TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29812       ENDIF
29813
29814       RETURN
29815       END
29816
29817 *$ CREATE DT_EVTHIS.FOR
29818 *COPY DT_EVTHIS
29819 *
29820 *===evthis=============================================================*
29821 *
29822       SUBROUTINE DT_EVTHIS(NEVT)
29823
29824 ************************************************************************
29825 * Dump content of temorary histograms into /DTHIS1/. This subroutine   *
29826 * is called after each event and for the last event before any call    *
29827 * to OUTHGR.                                                           *
29828 *         NEVT   number of events dumped, this is only needed to       *
29829 *                get the normalization after the last event            *
29830 * This version dated 23.4.95 is written  by S. Roesler.                *
29831 ************************************************************************
29832
29833       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29834       SAVE
29835
29836       PARAMETER ( LINP = 10 ,
29837      &            LOUT = 6 ,
29838      &            LDAT = 9 )
29839
29840       LOGICAL LNOETY
29841
29842       PARAMETER (ZERO = 0.0D0,
29843      &           ONE  = 1.0D0,
29844      &           TINY = 1.0D-10)
29845
29846 * histograms
29847
29848       PARAMETER (NHIS=150, NDIM=250)
29849
29850       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29851      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29852
29853 * auxiliary common for histograms
29854       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29855
29856       DATA NCEVT /0/
29857
29858       NCEVT = NCEVT+1
29859       NEVT  = NCEVT
29860
29861       DO 1 I=1,IHISL
29862          LNOETY = .TRUE.
29863          DO 2 J=1,IBINS(I)
29864             IF (TMPHIS(1,I,J).GT.ZERO) THEN
29865                LNOETY = .FALSE.
29866                HIST(2,I,J)   = HIST(2,I,J)+ONE
29867                HIST(7,I,J)   = HIST(7,I,J)+TMPHIS(1,I,J)
29868                DENTRY(2,I)   = DENTRY(2,I)+TMPHIS(1,I,J)
29869                AVX           = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29870                HIST(3,I,J)   = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29871                HIST(4,I,J)   = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29872                HIST(5,I,J)   = HIST(5,I,J)+TMPHIS(3,I,J)
29873                HIST(6,I,J)   = HIST(6,I,J)+TMPHIS(3,I,J)**2
29874                TMPHIS(1,I,J) = ZERO
29875                TMPHIS(2,I,J) = ZERO
29876                TMPHIS(3,I,J) = ZERO
29877             ENDIF
29878     2    CONTINUE
29879          IF (LNOETY) THEN
29880             IF (TMPUFL(I).GT.ZERO) THEN
29881                UNDERF(I) = UNDERF(I)+ONE
29882                TMPUFL(I) = ZERO
29883             ELSEIF (TMPOFL(I).GT.ZERO) THEN
29884                OVERF(I)  = OVERF(I)+ONE
29885                TMPOFL(I) = ZERO
29886             ENDIF
29887          ELSE
29888             DENTRY(1,I) = DENTRY(1,I)+ONE
29889          ENDIF
29890     1 CONTINUE
29891
29892       RETURN
29893       END
29894
29895 *$ CREATE DT_OUTHGR.FOR
29896 *COPY DT_OUTHGR
29897 *
29898 *===outhgr=============================================================*
29899 *
29900       SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29901      &                  ILOGY,INORM,NMODE)
29902
29903 ************************************************************************
29904 *                                                                      *
29905 *     Plot histogram(s) to standard output unit                        *
29906 *                                                                      *
29907 *         I1..6         indices of histograms to be plotted            *
29908 *         CHEAD,IHEAD   header string,integer                          *
29909 *         NEVTS         number of events                               *
29910 *         FAC           scaling factor                                 *
29911 *         ILOGY   = 1   logarithmic y-axis                             *
29912 *         INORM         normalization                                  *
29913 *                 = 0   no further normalization (FAC is obsolete)     *
29914 *                 = 1   per event and bin width                        *
29915 *                 = 2   per entry and bin width                        *
29916 *                 = 3   per bin entry                                  *
29917 *                 = 4   per event and "bin width" x1^2...x2^2          *
29918 *                 = 5   per event and "log. bin width" ln x1..ln x2    *
29919 *                 = 6   per event                                      *
29920 *         MODE    = 0   no output but normalization applied            *
29921 *                 = 1   all valid histograms separately (small frame)  *
29922 *                       all valid histograms separately (small frame)  *
29923 *                 = -1  and tables as histograms                       *
29924 *                 = 2   all valid histograms (one plot, wide frame)    *
29925 *                       all valid histograms (one plot, wide frame)    *
29926 *                 = -2  and tables as histograms                       *
29927 *                                                                      *
29928 *                                                                      *
29929 *     Note: All histograms to be plotted with one call to this         *
29930 *           subroutine and |MODE|=2 must have the same bin structure!  *
29931 *           There is no test included ensuring this fact.              *
29932 *                                                                      *
29933 * This version dated 23.4.95 is written  by S. Roesler.                *
29934 ************************************************************************
29935
29936       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29937       SAVE
29938
29939       PARAMETER ( LINP = 10 ,
29940      &            LOUT = 6 ,
29941      &            LDAT = 9 )
29942
29943       CHARACTER*72 CHEAD
29944
29945       PARAMETER (ZERO   =  0.0D0,
29946      &           IZERO  =  0,
29947      &           ONE    =  1.0D0,
29948      &           TWO    =  2.0D0,
29949      &           OHALF  =  0.5D0,
29950      &           EPS    =  1.0D-5,
29951      &           TINY   =  1.0D-8,
29952      &           SMALL  =  -1.0D8,
29953      &           RLARGE =  1.0D8 )
29954
29955 * histograms
29956
29957       PARAMETER (NHIS=150, NDIM=250)
29958
29959       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29960      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29961
29962       PARAMETER (NDIM2 = 2*NDIM)
29963       DIMENSION XX(NDIM2),YY(NDIM2)
29964
29965       PARAMETER (NHISTO = 6)
29966       DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
29967      &          IDX(NHISTO)
29968
29969       CHARACTER*43 CNORM(0:8)
29970       DATA CNORM /'no further normalization                   ',
29971      &            'per event and bin width                    ',
29972      &            'per entry1 and bin width                   ',
29973      &            'per bin entry                              ',
29974      &            'per event and "bin width" x1^2...x2^2      ',
29975      &            'per event and "log. bin width" ln x1..ln x2',
29976      &            'per event                                  ',
29977      &            'per bin entry1                             ',
29978      &            'per entry2 and bin width                   '/
29979
29980       IDX1(1) = I1
29981       IDX1(2) = I2
29982       IDX1(3) = I3
29983       IDX1(4) = I4
29984       IDX1(5) = I5
29985       IDX1(6) = I6
29986
29987       MODE = NMODE
29988
29989 * initialization if "wide frame" is requested
29990       IF (ABS(MODE).EQ.2) THEN
29991          DO 1 I=1,NHISTO
29992             DO 2 J=1,NDIM
29993                XX1(J,I) = ZERO
29994                YY1(J,I) = ZERO
29995     2       CONTINUE
29996     1    CONTINUE
29997       ENDIF
29998
29999 * plot header
30000       WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
30001
30002 * check histogram indices
30003       NHI = 0
30004       DO 3 I=1,NHISTO
30005          IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30006             IF (ISWI(IDX1(I)).NE.0) THEN
30007                IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30008                   WRITE(LOUT,1000)
30009      &                 IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30010  1000             FORMAT(/,1X,'OUTHGR:   warning!  no entries in',
30011      &                   ' histogram ',I3,/,21X,'underflows:',F10.0,
30012      &                   '   overflows:  ',F10.0)
30013                ELSE
30014                   NHI = NHI+1
30015                   IDX(NHI) = IDX1(I)
30016                ENDIF
30017             ENDIF
30018          ENDIF
30019     3 CONTINUE
30020       IF (NHI.EQ.0) THEN
30021          WRITE(LOUT,1001)
30022  1001    FORMAT(/,1X,'OUTHGR:   warning!  histogram indices not valid')
30023          RETURN
30024       ENDIF
30025
30026 * check normalization request
30027       IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30028      &     ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30029      &                        (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30030      &     (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30031          WRITE(LOUT,1002) NEVTS,INORM,FAC
30032  1002    FORMAT(/,1X,'OUTHGR:   warning!  normalization request not ',
30033      &          'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30034      &          'FAC = ',E11.4)
30035          RETURN
30036       ENDIF
30037
30038       WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30039
30040 * apply normalization
30041       DO 4 N=1,NHI
30042
30043          I = IDX(N)
30044
30045          IF (ISWI(I).EQ.1) THEN
30046             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30047  1003       FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30048      &             ' to',2X,E10.4,',',2X,I3,' bins')
30049          ELSEIF (ISWI(I).EQ.2) THEN
30050             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30051             WRITE(LOUT,1007)
30052  1007       FORMAT(1X,'user defined bin structure')
30053          ELSEIF (ISWI(I).EQ.3) THEN
30054             WRITE(LOUT,1004)
30055      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30056  1004       FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30057      &             ' to',2X,E10.4,',',2X,I3,' bins')
30058          ELSEIF (ISWI(I).EQ.4) THEN
30059             WRITE(LOUT,1004)
30060      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30061             WRITE(LOUT,1007)
30062          ELSE
30063             WRITE(LOUT,1008) ISWI(I)
30064  1008       FORMAT(/,1X,'warning!  inconsistent bin structure flag ',I4)
30065          ENDIF
30066          WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30067  1005    FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30068      &          ' overfl.:',F8.0)
30069          WRITE(LOUT,1009) CNORM(INORM)
30070  1009    FORMAT(1X,'normalization: ',A,/)
30071
30072          DO 5 K=1,IBINS(I)
30073             CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30074             YMEAN = FAC*YMEAN
30075             YERR  = FAC*YERR
30076             WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30077             WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30078  1006       FORMAT(1X,5E11.3)
30079 *    small frame
30080             II = 2*K
30081             XX(II-1) = HIST(1,I,K)
30082             XX(II)   = HIST(1,I,K+1)
30083             YY(II-1) = YMEAN
30084             YY(II)   = YMEAN
30085 *    wide frame
30086             XX1(K,N) = XMEAN
30087             IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30088      &         XX1(K,N) = LOG10(XMEAN)
30089             YY1(K,N) = YMEAN
30090     5    CONTINUE
30091
30092 * plot small frame
30093          IF (ABS(MODE).EQ.1) THEN
30094             IBIN2 = 2*IBINS(I)
30095             WRITE(LOUT,'(/,1X,A)') 'Preview:'
30096             IF(ILOGY.EQ.1) THEN
30097               CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30098             ELSE
30099               CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30100             ENDIF
30101          ENDIF
30102
30103     4 CONTINUE
30104
30105 * plot wide frame
30106       IF (ABS(MODE).EQ.2) THEN
30107          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30108          NSIZE = NDIM*NHISTO
30109          DXLOW = HIST(1,IDX(1),1)
30110          DDX   = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30111          YLOW  = RLARGE
30112          YHI   = SMALL
30113          DO 6 I=1,NHISTO
30114             DO 7 J=1,NDIM
30115                IF (YY1(J,I).LT.YLOW) THEN
30116                   IF (ILOGY.EQ.1) THEN
30117                      IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30118                   ELSE
30119                      YLOW = YY1(J,I)
30120                   ENDIF
30121                ENDIF
30122                IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30123     7       CONTINUE
30124     6    CONTINUE
30125          DY = (YHI-YLOW)/DBLE(NDIM)
30126          IF (DY.LE.ZERO) THEN
30127             WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30128      &         'OUTHGR:   warning! zero bin width for histograms ',
30129      &         IDX,': ',YLOW,YHI
30130             RETURN
30131          ENDIF
30132          IF (ILOGY.EQ.1) THEN
30133             YLOW = LOG10(YLOW)
30134             DY   = (LOG10(YHI)-YLOW)/100.0D0
30135             DO 8 I=1,NHISTO
30136                DO 9 J=1,NDIM
30137                   IF (YY1(J,I).LE.ZERO) THEN
30138                      YY1(J,I) = YLOW
30139                   ELSE
30140                      YY1(J,I) = LOG10(YY1(J,I))
30141                   ENDIF
30142     9          CONTINUE
30143     8       CONTINUE
30144          ENDIF
30145          CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30146       ENDIF
30147
30148       RETURN
30149       END
30150
30151 *$ CREATE DT_GETBIN.FOR
30152 *COPY DT_GETBIN
30153 *
30154 *===getbin=============================================================*
30155 *
30156       SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30157      &                  XMEAN,YMEAN,YERR)
30158
30159 ************************************************************************
30160 * This version dated 23.4.95 is written  by S. Roesler.                *
30161 ************************************************************************
30162
30163       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30164       SAVE
30165
30166       PARAMETER ( LINP = 10 ,
30167      &            LOUT = 6 ,
30168      &            LDAT = 9 )
30169
30170       PARAMETER (ZERO   = 0.0D0,
30171      &           ONE    = 1.0D0,
30172      &           TINY35 = 1.0D-35)
30173
30174 * histograms
30175
30176       PARAMETER (NHIS=150, NDIM=250)
30177
30178       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30179      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30180
30181       XLOW = HIST(1,IHIS,IBIN)
30182       XHI  = HIST(1,IHIS,IBIN+1)
30183       IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30184          XLOW = 10**XLOW
30185          XHI  = 10**XHI
30186       ENDIF
30187       IF (NORM.EQ.2) THEN
30188          DX   = XHI-XLOW
30189          NEVT = INT(DENTRY(1,IHIS))
30190       ELSEIF (NORM.EQ.3) THEN
30191          DX   = ONE
30192          NEVT = INT(HIST(2,IHIS,IBIN))
30193       ELSEIF (NORM.EQ.4) THEN
30194          DX   = XHI**2-XLOW**2
30195          NEVT = KEVT
30196       ELSEIF (NORM.EQ.5) THEN
30197          DX   = LOG(ABS(XHI))-LOG(ABS(XLOW))
30198          NEVT = KEVT
30199       ELSEIF (NORM.EQ.6) THEN
30200          DX   = ONE
30201          NEVT = KEVT
30202       ELSEIF (NORM.EQ.7) THEN
30203          DX   = ONE
30204          NEVT = INT(HIST(7,IHIS,IBIN))
30205       ELSEIF (NORM.EQ.8) THEN
30206          DX   = XHI-XLOW
30207          NEVT = INT(DENTRY(2,IHIS))
30208       ELSE
30209          DX   = ABS(XHI-XLOW)
30210          NEVT = KEVT
30211       ENDIF
30212       IF (ABS(DX).LT.TINY35) DX = ONE
30213       NEVT   = MAX(NEVT,1)
30214       YMEAN  = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30215       YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30216       YERR   = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30217       YSUM   = HIST(5,IHIS,IBIN)
30218       IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30219 C     XMEAN  = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30220       XMEAN  = HIST(3,IHIS,IBIN)/YSUM
30221       IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30222
30223       RETURN
30224       END
30225
30226 *$ CREATE DT_JOIHIS.FOR
30227 *COPY DT_JOIHIS
30228 *
30229 *===joihis=============================================================*
30230 *
30231       SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30232
30233 ************************************************************************
30234 *                                                                      *
30235 *     Operation on histograms.                                         *
30236 *                                                                      *
30237 *     input:  IH1,IH2      histogram indices to be joined              *
30238 *             COPER        character defining the requested operation, *
30239 *                          i.e. '+', '-', '*', '/'                     *
30240 *             FAC1,FAC2    factors for joining, i.e.                   *
30241 *                          FAC1*histo1 COPER FAC2*histo2               *
30242 *                                                                      *
30243 * This version dated 23.4.95 is written  by S. Roesler.                *
30244 ************************************************************************
30245
30246       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30247       SAVE
30248
30249       PARAMETER ( LINP = 10 ,
30250      &            LOUT = 6 ,
30251      &            LDAT = 9 )
30252
30253       CHARACTER COPER*1
30254
30255       PARAMETER (ZERO   =  0.0D0,
30256      &           ONE    =  1.0D0,
30257      &           OHALF  =  0.5D0,
30258      &           TINY8  =  1.0D-8,
30259      &           SMALL  =  -1.0D8,
30260      &           RLARGE =  1.0D8 )
30261
30262 * histograms
30263
30264       PARAMETER (NHIS=150, NDIM=250)
30265
30266       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30267      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30268
30269       PARAMETER (NDIM2 = 2*NDIM)
30270       DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30271
30272       CHARACTER*43 CNORM(0:6)
30273       DATA CNORM /'no further normalization                   ',
30274      &            'per event and bin width                    ',
30275      &            'per entry and bin width                    ',
30276      &            'per bin entry                              ',
30277      &            'per event and "bin width" x1^2...x2^2      ',
30278      &            'per event and "log. bin width" ln x1..ln x2',
30279      &            'per event                                  '/
30280
30281 * check histogram indices
30282       IF ((IH1.LT.    1).OR.(IH2.LT.    1).OR.
30283      &    (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30284          WRITE(LOUT,1000) IH1,IH2,IHISL
30285  1000    FORMAT(1X,'JOIHIS:   warning!  inconsistent histogram ',
30286      &          'indices (',I3,',',I3,'),',/,21X,'valid range:  1,',I3)
30287          GOTO 9999
30288       ENDIF
30289
30290 * check bin structure of histograms to be joined
30291       IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30292          WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30293  1001    FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30294      &          ' and ',I3,' failed',/,21X,
30295      &          'due to different numbers of bins (',I3,',',I3,')')
30296          GOTO 9999
30297       ENDIF
30298       DO 1 K=1,IBINS(IH1)+1
30299          IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30300             WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30301  1002       FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30302      &             ' and ',I3,' failed at bin edge ',I3,/,21X,
30303      &             'X1,X2 = ',2E11.4)
30304             GOTO 9999
30305          ENDIF
30306     1 CONTINUE
30307
30308       WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30309  1003 FORMAT(1X,'JOIHIS:   joining histograms ',I3,',',I3,' with ',
30310      &       'operation ',A,/,11X,'and factors ',2E11.4)
30311       WRITE(LOUT,1004) CNORM(NORM)
30312  1004 FORMAT(1X,'normalization: ',A,/)
30313
30314       DO 2 K=1,IBINS(IH1)
30315          CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30316          CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30317          XLOW  = XLOW1
30318          XHI   = XHI1
30319          XMEAN = OHALF*(XMEAN1+XMEAN2)
30320          IF (COPER.EQ.'+') THEN
30321             YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30322          ELSEIF (COPER.EQ.'*') THEN
30323             YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30324          ELSEIF (COPER.EQ.'/') THEN
30325             IF (YMEAN2.EQ.ZERO) THEN
30326                YMEAN = ZERO
30327             ELSE
30328                IF (FAC2.EQ.ZERO) FAC2 = ONE
30329                YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30330             ENDIF
30331          ELSE
30332             GOTO 9998
30333          ENDIF
30334          WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30335          WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30336  1006    FORMAT(1X,5E11.3)
30337 *    small frame
30338          II = 2*K
30339          XX(II-1) = HIST(1,IH1,K)
30340          XX(II)   = HIST(1,IH1,K+1)
30341          YY(II-1) = YMEAN
30342          YY(II)   = YMEAN
30343 *    wide frame
30344          XX1(K) = XMEAN
30345          IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30346          YY1(K) = YMEAN
30347     2 CONTINUE
30348
30349 * plot small frame
30350       IF (ABS(MODE).EQ.1) THEN
30351          IBIN2 = 2*IBINS(IH1)
30352          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30353          IF(ILOGY.EQ.1) THEN
30354            CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30355          ELSE
30356            CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30357          ENDIF
30358       ENDIF
30359
30360 * plot wide frame
30361       IF (ABS(MODE).EQ.2) THEN
30362          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30363          NSIZE = NDIM
30364          DXLOW = HIST(1,IH1,1)
30365          DDX   = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30366          YLOW  = RLARGE
30367          YHI   = SMALL
30368          DO 3 I=1,NDIM
30369             IF (YY1(I).LT.YLOW) THEN
30370                IF (ILOGY.EQ.1) THEN
30371                   IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30372                ELSE
30373                   YLOW = YY1(I)
30374                ENDIF
30375             ENDIF
30376             IF (YY1(I).GT.YHI) YHI = YY1(I)
30377     3    CONTINUE
30378          DY = (YHI-YLOW)/DBLE(NDIM)
30379          IF (DY.LE.ZERO) THEN
30380             WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30381      &         'JOIHIS:   warning! zero bin width for histograms ',
30382      &         IH1,IH2,': ',YLOW,YHI
30383             RETURN
30384          ENDIF
30385          IF (ILOGY.EQ.1) THEN
30386             YLOW = LOG10(YLOW)
30387             DY   = (LOG10(YHI)-YLOW)/100.0D0
30388             DO 4 I=1,NDIM
30389                IF (YY1(I).LE.ZERO) THEN
30390                   YY1(I) = YLOW
30391                ELSE
30392                   YY1(I) = LOG10(YY1(I))
30393                ENDIF
30394     4       CONTINUE
30395          ENDIF
30396          CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30397       ENDIF
30398
30399       RETURN
30400
30401  9998 CONTINUE
30402       WRITE(LOUT,1005) COPER
30403  1005 FORMAT(1X,'JOIHIS:   unknown operation ',A)
30404
30405  9999 CONTINUE
30406       RETURN
30407       END
30408
30409 *$ CREATE DT_XGRAPH.FOR
30410 *COPY DT_XGRAPH
30411 *
30412 *===qgraph=============================================================*
30413 *
30414       SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30415 C***********************************************************************
30416 C
30417 C     calculate quasi graphic picture with 25 lines and 79 columns
30418 C     ranges will be chosen automatically
30419 C
30420 C     input     N          dimension of input fields
30421 C               IARG       number of curves (fields) to plot
30422 C               X          field of X
30423 C               Y1         field of Y1
30424 C               Y2         field of Y2
30425 C
30426 C This subroutine is written by R. Engel.
30427 C***********************************************************************
30428       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30429       SAVE
30430
30431       PARAMETER ( LINP = 10 ,
30432      &            LOUT = 6 ,
30433      &            LDAT = 9 )
30434
30435 C
30436       DIMENSION X(N),Y1(N),Y2(N)
30437       PARAMETER (EPS=1.D-30)
30438       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30439       CHARACTER SYMB(5)
30440       CHARACTER COL(0:149,0:49)
30441 C
30442       DATA SYMB /'0','e','z','#','x'/
30443 C
30444       ISPALT=IBREIT-10
30445 C
30446 C***  automatic range fitting
30447 C
30448       XMAX=X(1)
30449       XMIN=X(1)
30450       DO 600 I=1,N
30451          XMAX=MAX(X(I),XMAX)
30452          XMIN=MIN(X(I),XMIN)
30453  600  CONTINUE
30454       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30455 C
30456       ITEST=0
30457       DO 1100 K=0,IZEIL-1
30458          ITEST=ITEST+1
30459          IF (ITEST.EQ.IYRAST) THEN
30460             DO 1010 L=1,ISPALT-1
30461                COL(L,K)='-'
30462 1010        CONTINUE
30463             COL(ISPALT,K)='+'
30464             ITEST=0
30465             DO 1020 L=0,ISPALT-1,IXRAST
30466                COL(L,K)='+'
30467 1020        CONTINUE
30468          ELSE
30469             DO 1030 L=1,ISPALT-1
30470                COL(L,K)=' '
30471 1030        CONTINUE
30472             DO 1040 L=0,ISPALT-1,IXRAST
30473                COL(L,K)='|'
30474 1040        CONTINUE
30475             COL(ISPALT,K)='|'
30476          ENDIF
30477 1100  CONTINUE
30478 C
30479 C***  plot curve Y1
30480 C
30481       YMAX=Y1(1)
30482       YMIN=Y1(1)
30483       DO 500 I=1,N
30484          YMAX=MAX(Y1(I),YMAX)
30485          YMIN=MIN(Y1(I),YMIN)
30486 500   CONTINUE
30487       IF(IARG.GT.1) THEN
30488         DO 550 I=1,N
30489            YMAX=MAX(Y2(I),YMAX)
30490            YMIN=MIN(Y2(I),YMIN)
30491 550     CONTINUE
30492       ENDIF
30493       YMAX=(YMAX-YMIN)/40.0D0+YMAX
30494       YMIN=YMIN-(YMAX-YMIN)/40.0D0
30495       YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30496       IF(YZOOM.LT.EPS) THEN
30497         WRITE(LOUT,'(1X,A)')
30498      &    'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30499         RETURN
30500       ENDIF
30501 C
30502 C***  plot curve Y1
30503 C
30504       ILAST=-1
30505       LLAST=-1
30506       DO 1200 K=1,N
30507          L=NINT((X(K)-XMIN)/XZOOM)
30508          I=NINT((YMAX-Y1(K))/YZOOM)
30509          IF(ILAST.GE.0) THEN
30510            LD = L-LLAST
30511            ID = I-ILAST
30512            DO 55 II=0,LD,SIGN(1,LD)
30513              DO 66 KK=0,ID,SIGN(1,ID)
30514                COL(II+LLAST,KK+ILAST)=SYMB(1)
30515  66          CONTINUE
30516  55        CONTINUE
30517          ELSE
30518            COL(L,I)=SYMB(1)
30519          ENDIF
30520          ILAST = I
30521          LLAST = L
30522 1200  CONTINUE
30523 C
30524       IF(IARG.GT.1) THEN
30525 C
30526 C***  plot curve Y2
30527 C
30528         DO 1250 K=1,N
30529            L=NINT((X(K)-XMIN)/XZOOM)
30530            I=NINT((YMAX-Y2(K))/YZOOM)
30531            COL(L,I)=SYMB(2)
30532 1250    CONTINUE
30533       ENDIF
30534 C
30535 C***  write it
30536 C
30537       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30538 C
30539 C***  write range of X
30540 C
30541       XZOOM = (XMAX-XMIN)/DBLE(7)
30542       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30543 C
30544       DO 1300 K=0,IZEIL-1
30545          YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30546          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30547  110     FORMAT(1X,1PE9.2,70A1)
30548 1300  CONTINUE
30549 C
30550 C***  write range of X
30551 C
30552       XZOOM = (XMAX-XMIN)/DBLE(7)
30553       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30554       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30555  120  FORMAT(6X,7(1PE10.3))
30556       END
30557
30558 *$ CREATE DT_XGLOGY.FOR
30559 *COPY DT_XGLOGY
30560 *
30561 *===qglogy=============================================================*
30562 *
30563       SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30564 C***********************************************************************
30565 C
30566 C     calculate quasi graphic picture with 25 lines and 79 columns
30567 C     logarithmic y axis
30568 C     ranges will be chosen automatically
30569 C
30570 C     input     N          dimension of input fields
30571 C               IARG       number of curves (fields) to plot
30572 C               X          field of X
30573 C               Y1         field of Y1
30574 C               Y2         field of Y2
30575 C
30576 C This subroutine is written by R. Engel.
30577 C***********************************************************************
30578 C
30579       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30580       SAVE
30581
30582       PARAMETER ( LINP = 10 ,
30583      &            LOUT = 6 ,
30584      &            LDAT = 9 )
30585
30586       DIMENSION X(N),Y1(N),Y2(N)
30587       PARAMETER (EPS=1.D-30)
30588       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30589       CHARACTER SYMB(5)
30590       CHARACTER COL(0:149,0:49)
30591       PARAMETER (DEPS = 1.D-10)
30592 C
30593       DATA SYMB /'0','e','z','#','x'/
30594 C
30595       ISPALT=IBREIT-10
30596 C
30597 C***  automatic range fitting
30598 C
30599       XMAX=X(1)
30600       XMIN=X(1)
30601       DO 600 I=1,N
30602          XMAX=MAX(X(I),XMAX)
30603          XMIN=MIN(X(I),XMIN)
30604  600  CONTINUE
30605       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30606 C
30607       ITEST=0
30608       DO 1100 K=0,IZEIL-1
30609          ITEST=ITEST+1
30610          IF (ITEST.EQ.IYRAST) THEN
30611             DO 1010 L=1,ISPALT-1
30612                COL(L,K)='-'
30613 1010        CONTINUE
30614             COL(ISPALT,K)='+'
30615             ITEST=0
30616             DO 1020 L=0,ISPALT-1,IXRAST
30617                COL(L,K)='+'
30618 1020        CONTINUE
30619          ELSE
30620             DO 1030 L=1,ISPALT-1
30621                COL(L,K)=' '
30622 1030        CONTINUE
30623             DO 1040 L=0,ISPALT-1,IXRAST
30624                COL(L,K)='|'
30625 1040        CONTINUE
30626             COL(ISPALT,K)='|'
30627          ENDIF
30628 1100  CONTINUE
30629 C
30630 C***  plot curve Y1
30631 C
30632       YMAX=Y1(1)
30633       YMIN=MAX(Y1(1),EPS)
30634       DO 500 I=1,N
30635          YMAX =MAX(Y1(I),YMAX)
30636          IF(Y1(I).GT.EPS) THEN
30637            IF(YMIN.EQ.EPS) THEN
30638              YMIN = Y1(I)/10.D0
30639            ELSE
30640              YMIN = MIN(Y1(I),YMIN)
30641            ENDIF
30642          ENDIF
30643 500   CONTINUE
30644       IF(IARG.GT.1) THEN
30645         DO 550 I=1,N
30646            YMAX=MAX(Y2(I),YMAX)
30647            IF(Y2(I).GT.EPS) THEN
30648              IF(YMIN.EQ.EPS) THEN
30649                YMIN = Y2(I)
30650              ELSE
30651                YMIN = MIN(Y2(I),YMIN)
30652              ENDIF
30653            ENDIF
30654 550     CONTINUE
30655       ENDIF
30656 C
30657       DO 560 I=1,N
30658         Y1(I) = MAX(Y1(I),YMIN)
30659  560  CONTINUE
30660       IF(IARG.GT.1) THEN
30661         DO 570 I=1,N
30662           Y2(I) = MAX(Y2(I),YMIN)
30663  570    CONTINUE
30664       ENDIF
30665 C
30666       IF(YMAX.LE.YMIN) THEN
30667         WRITE(LOUT,'(/1X,A,2E12.3,/)')
30668      &     'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30669         WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30670         RETURN
30671       ENDIF
30672 C
30673       YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30674       YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30675       YZOOM=(YMA-YMI)/DBLE(IZEIL)
30676       IF(YZOOM.LT.EPS) THEN
30677         WRITE(LOUT,'(1X,A)')
30678      &    'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30679         RETURN
30680       ENDIF
30681 C
30682 C***  plot curve Y1
30683 C
30684       ILAST=-1
30685       LLAST=-1
30686       DO 1200 K=1,N
30687          L=NINT((X(K)-XMIN)/XZOOM)
30688          I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30689          IF(ILAST.GE.0) THEN
30690            LD = L-LLAST
30691            ID = I-ILAST
30692            DO 55 II=0,LD,SIGN(1,LD)
30693              DO 66 KK=0,ID,SIGN(1,ID)
30694                COL(II+LLAST,KK+ILAST)=SYMB(1)
30695  66          CONTINUE
30696  55        CONTINUE
30697          ELSE
30698            COL(L,I)=SYMB(1)
30699          ENDIF
30700          ILAST = I
30701          LLAST = L
30702 1200  CONTINUE
30703 C
30704       IF(IARG.GT.1) THEN
30705 C
30706 C***  plot curve Y2
30707 C
30708         DO 1250 K=1,N
30709            L=NINT((X(K)-XMIN)/XZOOM)
30710            I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30711            COL(L,I)=SYMB(2)
30712 1250    CONTINUE
30713       ENDIF
30714 C
30715 C***  write it
30716 C
30717       WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30718       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30719 C
30720 C***  write range of X
30721 C
30722       XZOOM1 = (XMAX-XMIN)/DBLE(7)
30723       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30724 C
30725       DO 1300 K=0,IZEIL-1
30726          YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30727          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30728  110     FORMAT(1X,1PE9.2,70A1)
30729 1300  CONTINUE
30730 C
30731 C***  write range of X
30732 C
30733       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30734       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30735  120  FORMAT(6X,7(1PE10.3))
30736 C
30737       END
30738
30739 *$ CREATE DT_SRPLOT.FOR
30740 *COPY DT_SRPLOT
30741 *
30742 *===plot===============================================================*
30743 *
30744       SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30745
30746       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30747       SAVE
30748
30749       PARAMETER ( LINP = 10 ,
30750      &            LOUT = 6 ,
30751      &            LDAT = 9 )
30752
30753 *
30754 *     initial version
30755 *     J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30756 *     This is a subroutine of fluka to plot Y across the page
30757 *     as a function of X down the page. Up to 37 curves can be
30758 *     plotted in the same picture with different plotting characters.
30759 *     Output of first 10 overprinted characters addad by FB 88
30760 *  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30761 *
30762 *     Input Variables:
30763 *        X   = array containing the values of X
30764 *        Y   = array containing the values of Y
30765 *        N   = number of values in X and in Y
30766 *              can exceed the fixed number of lines
30767 *        M   = number of different curves X,Y are containing
30768 *        MM  = number of points in each curve i.e. N=M*MM
30769 *        XO  = smallest value of X to be plotted
30770 *        DX  = increment of X between subsequent lines
30771 *        YO  = smallest value of Y to be plotted
30772 *        DY  = increment of Y between subsequent character spaces
30773 *
30774 *        other variables used inside:
30775 *        XX  = numbers along the X-coordinate axis
30776 *        YY  = numbers along the Y-coordinate axis
30777 *        LL  = ten lines temporary storage for the plot
30778 *        L   = character set used to plot different curves
30779 *        LOV = memorizes overprinted symbols
30780 *              the first 10 overprinted symbols are printed on
30781 *              the end of the line to avoid ambiguities
30782 *              (added by FB as considered quite helpful)
30783 *
30784 *********************************************************************
30785 *
30786       DIMENSION XX(61),YY(61),LL(101,10)
30787       DIMENSION X(N),Y(N),L(40),LOV(40,10)
30788       INTEGER*4 LL, L, LOV
30789       DATA  L/
30790      11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30791      21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30792      31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30793      41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H  /
30794 *
30795 *
30796       MN=51
30797       DO 10 I=1,MN
30798         AI=I-1
30799    10 XX(I)=XO+AI*DX
30800       DO 20 I=1,11
30801         AI=I-1
30802    20 YY(I)=YO+10.0D0*AI*DY
30803       WRITE(LOUT, 500) (YY(I),I=1,11)
30804       MMN=MN-1
30805 *
30806 *
30807       DO 90 JJ=1,MMN,10
30808         JJJ=JJ-1
30809         DO 30 I=1,101
30810           DO 30 J=1,10
30811    30   LL(I,J)=L(40)
30812         DO 40 I=1,101
30813    40   LL(I,1)=L(39)
30814         DO 50 I=1,101,10
30815           DO 50 J=1,10
30816    50   LL(I,J)=L(38)
30817         DO 60 I=1,40
30818           DO 60 J=1,10
30819    60   LOV(I,J)=L(40)
30820 *
30821 *
30822         DO 70 I=1,M
30823           DO 70 J=1,MM
30824             II=J+(I-1)*MM
30825             AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30826             AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30827             AIX=AIX-DBLE(JJJ)
30828 *           changed Sept.88 by FB to avoid INTEGER OVERFLOW
30829             IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30830      +      . AIY .LT. 102.D0) THEN
30831               IX=INT(AIX)
30832               IY=INT(AIY)
30833               IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30834      +        THEN
30835                 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30836      +          =LL(IY,IX)
30837                 LL(IY,IX)=L(I)
30838               ENDIF
30839             ENDIF
30840    70   CONTINUE
30841 *
30842 *
30843         DO 80 I=1,10
30844           II=I+JJJ
30845           III=II+1
30846           WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30847      &                    (LOV(J,I),J=1,10)
30848    80   CONTINUE
30849    90 CONTINUE
30850 *
30851 *
30852       WRITE(LOUT, 520)
30853       WRITE(LOUT, 500) (YY(I),I=1,11)
30854       RETURN
30855 *
30856   500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30857   510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30858   520 FORMAT(20X,10('1---------'),'1')
30859       END
30860 *$ CREATE DT_DEFSET.FOR
30861 *COPY DT_DEFSET
30862 *
30863 *===defset=============================================================*
30864 *
30865       BLOCK DATA DT_DEFSET
30866
30867       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30868       SAVE
30869
30870 * flags for input different options
30871       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30872       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30873      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30874
30875       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30876
30877 * emulsion treatment
30878       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30879      &                NCOMPO,IEMUL
30880
30881 * / DTFLG1 /
30882       DATA IFRAG  / 2, 1 /
30883       DATA IRESCO / 1 /
30884       DATA IMSHL  / 1 /
30885       DATA IRESRJ / 0 /
30886       DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30887       DATA LEMCCK / .FALSE. /
30888       DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30889      &              .TRUE.,.TRUE.,.TRUE./
30890       DATA LSEADI / .TRUE. /
30891       DATA LEVAPO / .TRUE. /
30892       DATA IFRAME / 1 /
30893       DATA ITRSPT / 0 /
30894
30895 * / DTCOMP /
30896       DATA EMUFRA / NCOMPX*0.0D0 /
30897       DATA IEMUMA / NCOMPX*1 /
30898       DATA IEMUCH / NCOMPX*1 /
30899       DATA NCOMPO / 0 /
30900       DATA IEMUL  / 0 /
30901
30902       END
30903
30904 *$ CREATE DT_HADPRP.FOR
30905 *COPY DT_HADPRP
30906 *
30907 *===hadprp=============================================================*
30908 *
30909       BLOCK DATA DT_HADPRP
30910
30911       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30912       SAVE
30913
30914 * auxiliary common for reggeon exchange (DTUNUC 1.x)
30915       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30916      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30917      &                IQTCHR(-6:6),MQUARK(3,39)
30918
30919 * hadron index conversion (BAMJET <--> PDG)
30920       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30921      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30922      &                IAMCIN(210)
30923
30924 * names of hadrons used in input-cards
30925       CHARACTER*8 BTYPE
30926       COMMON /DTPAIN/ BTYPE(30)
30927
30928 * / DTQUAR /
30929 *----------------------------------------------------------------------*
30930 *                                                                      *
30931 *     Quark content of particles:                                      *
30932 *          index   quark   el. charge  bar. charge  isospin  isospin3  *
30933 *              1 = u          2/3          1/3        1/2       1/2    *
30934 *             -1 = ubar      -2/3         -1/3        1/2      -1/2    *
30935 *              2 = d         -1/3          1/3        1/2      -1/2    *
30936 *             -2 = dbar       1/3         -1/3        1/2       1/2    *
30937 *              3 = s         -1/3          1/3         0         0     *
30938 *             -3 = sbar       1/3         -1/3         0         0     *
30939 *              4 = c          2/3          1/3         0         0     *
30940 *             -4 = cbar      -2/3         -1/3         0         0     *
30941 *              5 = b         -1/3          1/3         0         0     *
30942 *             -5 = bbar       1/3         -1/3         0         0     *
30943 *              6 = t          2/3          1/3         0         0     *
30944 *             -6 = tbar      -2/3         -1/3         0         0     *
30945 *                                                                      *
30946 *         Mquark = particle quark composition (Paprop numbering)       *
30947 *         Iqechr = electric charge ( in 1/3 unit )                     *
30948 *         Iqbchr = baryonic charge ( in 1/3 unit )                     *
30949 *         Iqichr = isospin ( in 1/2 unit ), z component                *
30950 *         Iqschr = strangeness                                         *
30951 *         Iqcchr = charm                                               *
30952 *         Iquchr = beauty                                              *
30953 *         Iqtchr = ......                                              *
30954 *                                                                      *
30955 *----------------------------------------------------------------------*
30956       DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
30957       DATA IQBCHR / 6*-1, 0, 6*1 /
30958       DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
30959       DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
30960       DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
30961       DATA IQUCHR / 0, 1, 9*0, -1, 0 /
30962       DATA IQTCHR / -1, 11*0, 1 /
30963       DATA MQUARK /
30964      &   2, 1, 1,   -2,-1,-1,    0, 0, 0,    0, 0, 0,    0, 0, 0,
30965      &   0, 0, 0,    0, 0, 0,    2, 2, 1,   -2,-2,-1,    0, 0, 0,
30966      &   0, 0, 0,    0, 0, 0,    1,-2, 0,    2,-1, 0,    1,-3, 0,
30967      &   3,-1, 0,    1, 2, 3,   -1,-2,-3,    0, 0, 0,    2, 2, 3,
30968      &   1, 1, 3,    1, 2, 3,    1,-1, 0,    2,-3, 0,    3,-2, 0,
30969      &   2,-2, 0,    3,-3, 0,    0, 0, 0,    0, 0, 0,    0, 0, 0,
30970      &  -1,-1,-3,   -1,-2,-3,   -2,-2,-3,    1, 3, 3,   -1,-3,-3,
30971      &   2, 3, 3,   -2,-3,-3,    3, 3, 3,   -3,-3,-3 /
30972
30973 * / DTHAIC /
30974 * (renamed) (HAdron InDex COnversion)
30975 * translation table version filled up by r.e. 25.01.94                 *
30976       DATA IAMCIN /
30977      &2212,-2212,11,-11,12,              -12,22,2112,-2112,-13,
30978      &13,130,211,-211,321,               -321,3122,-3122,310,3112,
30979      &3222,3212,111,311,-311,            0,0,0,0,0,
30980      &221,213,113,-213,223,              323,313,-323,-313,10323,
30981      &10313,-10323,-10313,30323,30313,   -30323,-30313,3224,3214,3114,
30982      &3216,3218,2224,2214,2114,          1114,12224,12214,12114,11114,
30983      &99999,99999,22212,22112,32124,     31214,-2224,-2214,-2114,-1114,
30984      &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
30985      &5*99999,                           5*99999,
30986      &4*99999,331,                       333,3322,3312,-3222,-3212,
30987      &-3112,-3322,-3312,3224,3214,       3114,3324,3314,3334,-3224,
30988      &-3214,-3114,-3324,-3314,-3334,     421,411,-411,-421,431,
30989      &-431,441,423,413,-413,             -423,433,-433,20443,443,
30990      &-15,15,16,-16,14,                  -14,4122,4232,4132,4222,
30991      &4212,4112,3*99999,                 3*99999,-4122,-4232,
30992      &-4132,-4222,-4212,-4112,99999,     5*99999,
30993      &5*99999,                           5*99999,
30994      &10*99999,
30995      &5*99999 , 20211,20111,-20211,99999,20321,
30996      &-20321,20311,-20311,7*99999 ,
30997      &7*99999,12212,12112,99999/
30998
30999 * / DTHAIC /
31000 * (HAdron InDex COnversion)
31001       DATA (IPDG2(1,K),K=1,7)
31002      &   /   -11,   -12,   -13,   -15,   -16,   -14,     0/
31003       DATA (IBAM2(1,K),K=1,7)
31004      &   /     4,     6,    10,   131,   134,   136,     0/
31005       DATA (IPDG2(2,K),K=1,7)
31006      &   /    11,    12,    22,    13,    15,    16,    14/
31007       DATA (IBAM2(2,K),K=1,7)
31008      &   /     3,     5,     7,    11,   132,   133,   135/
31009       DATA (IPDG3(1,K),K=1,22)
31010      &   /  -211,  -321,  -311,  -213,  -323,  -313,  -411,  -421,
31011      &      -431,  -413,  -423,  -433,     0,     0,     0,     0,
31012      &         0,     0,     0,     0,     0,     0/
31013       DATA (IBAM3(1,K),K=1,22)
31014      &   /    14,    16,    25,    34,    38,    39,   118,   119,
31015      &       121,   125,   126,   128,     0,     0,     0,     0,
31016      &         0,     0,     0,     0,     0,     0/
31017       DATA (IPDG3(2,K),K=1,22)
31018      &   /   130,   211,   321,   310,   111,   311,   221,   213,
31019      &       113,   223,   323,   313,   331,   333,   421,   411,
31020      &       431,   441,   423,   413,   433,   443/
31021       DATA (IBAM3(2,K),K=1,22)
31022      &   /    12,    13,    15,    19,    23,    24,    31,    32,
31023      &        33,    35,    36,    37,    95,    96,   116,   117,
31024      &       120,   122,   123,   124,   127,   130/
31025       DATA (IPDG4(1,K),K=1,29)
31026      &   / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31027      &     -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31028      &     -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31029      &     -4212, -4112,     0,     0,     0/
31030       DATA (IBAM4(1,K),K=1,29)
31031      &   /     2,     9,    18,    67,    68,    69,    70,    75,
31032      &        76,    99,   100,   101,   102,   103,   110,   111,
31033      &       112,   113,   114,   115,   149,   150,   151,   152,
31034      &       153,   154,     0,     0,     0/
31035       DATA (IPDG4(2,K),K=1,29)
31036      &   /  2212,  2112,  3122,  3112,  3222,  3212,  3224,  3214,
31037      &      3114,  3216,  3218,  2224,  2214,  2114,  1114,  3322,
31038      &      3312,  3224,  3214,  3114,  3324,  3314,  3334,  4122,
31039      &      4232,  4132,  4222,  4212,  4112/
31040       DATA (IBAM4(2,K),K=1,29)
31041      &   /     1,     8,    17,    20,    21,    22,    48,    49,
31042      &        50,    51,    52,    53,    54,    55,    56,    97,
31043      &        98,   104,   105,   106,   107,   108,   109,   137,
31044      &       138,   139,   140,   141,   142/
31045       DATA (IPDG5(1,K),K=1,19)
31046      &   /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31047      &    -20211,-20321,-20311,     0,     0,     0,     0,     0,
31048      &         0,     0,     0/
31049       DATA (IBAM5(1,K),K=1,19)
31050      &   /    42,    43,    46,    47,    71,    72,    73,    74,
31051      &       188,   191,   193,     0,     0,     0,     0,     0,
31052      &         0,     0,     0/
31053       DATA (IPDG5(2,K),K=1,19)
31054      &   / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31055      &     22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31056      &     20311, 12212, 12112/
31057       DATA (IBAM5(2,K),K=1,19)
31058      &   /    40,    41,    44,    45,    57,    58,    59,    60,
31059      &        63,    64,    65,    66,   129,   186,   187,   190,
31060      &       192,   208,   209/
31061
31062 * / DTPAIN /
31063 * internal particle names
31064       DATA BTYPE / 'PROTON  ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31065      &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON  ' , 'NEUTRON ' , 'ANEUTRON' ,
31066      &'MUON+   ' , 'MUON-   ' , 'KAONLONG' , 'PION+   ' , 'PION-   ' ,
31067      &'KAON+   ' , 'KAON-   ' , 'LAMBDA  ' , 'ALAMBDA ' , 'KAONSHRT' ,
31068      &'SIGMA-  ' , 'SIGMA+  ' , 'SIGMAZER' , 'PIZERO  ' , 'KAONZERO' ,
31069      &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31070      &'BLANK   ' /
31071
31072       END
31073
31074 *$ CREATE DT_BLKD46.FOR
31075 *COPY DT_BLKD46
31076 *
31077 *===blkd46=============================================================*
31078 *
31079       BLOCK DATA DT_BLKD46
31080
31081       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31082       SAVE
31083
31084       PARAMETER ( AMELCT = 0.51099906         D-03 )
31085       PARAMETER ( AMMUON = 0.105658389        D+00 )
31086
31087 * particle properties (BAMJET index convention)
31088       CHARACTER*8  ANAME
31089       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31090      &                IICH(210),IIBAR(210),K1(210),K2(210)
31091
31092 * / DTPART /
31093 * Particle  masses Engel version JETSET compatible
31094 C     DATA (AAM(K),K=1,85) /
31095 C    &   .9383D+00, .9383D+00,  AMELCT  ,  AMELCT  , .0000D+00,
31096 C    &   .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON   ,
31097 C    &   AMMUON   , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31098 C    &   .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31099 C    &   .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31100 C    &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31101 C    &   .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31102 C    &   .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31103 C    &   .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31104 C    &   .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31105 C    &   .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31106 C    &   .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31107 C    &   .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31108 C    &   .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31109 C    &   .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31110 C    &   .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31111 C    &   .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01  /
31112 C     DATA (AAM(K),K=86,183) /
31113 C    &   .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31114 C    &   .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31115 C    &   .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31116 C    &   .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31117 C    &   .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31118 C    &   .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31119 C    &   .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31120 C    &   .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31121 C    &   .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31122 C    &   .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31123 C    &   .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31124 C    &   .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31125 C    &   .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31126 C    &   .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31127 C    &   .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31128 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31129 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31130 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31131 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31132 C    &   .1250D+01, .1250D+01, .1250D+01  /
31133 C     DATA (AAM ( I ), I = 184,210 ) /
31134 C    & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31135 C    & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31136 C    & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31137 C    & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31138 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31139 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31140 C    & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31141 C    & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31142 C    & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31143 * sr 25.1.06: particle masses adjusted to Pythia
31144       DATA (AAM(K),K=1,85) /
31145      &   .938270E+00,.938270E+00, AMELCT    , AMELCT    ,.000000E+00,
31146      &   .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON    ,
31147      &    AMMUON    ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31148      &   .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31149      &   .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31150      &     .0000D+00,  .0000D+00,  .0000D+00 , .0000D+00,  .0000D+00,
31151      &   .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31152      &   .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31153      &   .129000E+01,.129000E+01,.129000E+01,  .1421D+01,  .1421D+01,
31154      &     .1421D+01,  .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31155      &     .1820D+01,  .2030D+01,  .1231D+01,  .1232D+01,  .1233D+01,
31156      &     .1234D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,
31157      &     .1500D+01,  .1500D+01,  .1515D+01,  .1515D+01,  .1775D+01,
31158      &     .1775D+01,  .1231D+01,  .1232D+01,  .1233D+01,  .1234D+01,
31159      &     .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1515D+01,
31160      &     .1515D+01,  .2500D+01,  .4890D+00,  .4890D+00,  .4890D+00,
31161      &     .1300D+01,  .1300D+01,  .1300D+01,  .1300D+01,  .2200D+01  /
31162       DATA (AAM(K),K=86,183) /
31163      &     .2200D+01,  .2200D+01,  .2200D+01,  .1700D+01,  .1700D+01,
31164      &     .1700D+01,  .1700D+01,  .1820D+01,  .2030D+01,.957770E+00,
31165      &   .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31166      &   .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31167      &   .138720E+01,.153180E+01,  .1535D+01,.167245E+01,.138280E+01,
31168      &   .138370E+01,.138720E+01,.153180E+01,  .1535D+01,.167245E+01,
31169      &   .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31170      &   .196850E+01,.297980E+01,.200670E+01,  .2010D+01,  .2010D+01,
31171      &   .200670E+01,.211240E+01,.211240E+01,  .3686D+01,.309688E+01,
31172      &   .177700E+01,.177700E+01,  .0000D+00,  .0000D+00,  .0000D+00,
31173      &     .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31174      &   .245350E+01,.245210E+01,  .2560D+01,  .2560D+01,  .2730D+01,
31175      &     .3610D+01,  .3610D+01,  .3790D+01,.228490E+01,.246560E+01,
31176      &     .2460D+01,.245290E+01,.245350E+01,.245210E+01,  .2560D+01,
31177      &     .2560D+01,  .2730D+01,  .3610D+01,  .3610D+01,  .3790D+01,
31178      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31179      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31180      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31181      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31182      &     .1250D+01,  .1250D+01,  .1250D+01  /
31183       DATA (AAM ( I ), I = 184,210 ) /
31184      & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31185      & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31186      & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31187      & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31188      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31189      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31190      & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31191      & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31192      & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31193 * Particle  mean lives
31194       DATA (TAU(K),K=1,183) /
31195      &   .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31196      &   .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31197      &   .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31198      &   .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31199      &   .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31200      &   70*.0000D+00,
31201      &   .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31202      &   .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31203      &   .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31204      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31205      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31206      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31207      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31208      &   .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31209      &   .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31210      &   40*.0000D+00,
31211      &   .0000D+00, .0000D+00, .0000D+00  /
31212       DATA ( TAU ( I ), I = 184,210 ) /
31213      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31214      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31215      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31216      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31217      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
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 * Resonance width Gamma in GeV
31223       DATA (GA(K),K=  1,85) /
31224      &    30*.0000D+00,
31225      &   .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31226      &   .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31227      &   .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31228      &   .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31229      &   .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31230      &   .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31231      &   .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31232      &   .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31233      &   .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31234      &   .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31235      &   .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00  /
31236       DATA (GA(K),K= 86,183) /
31237      &   .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31238      &   .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31239      &   .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31240      &   .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31241      &   .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31242      &   .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31243      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31244      &   .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31245      &   .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31246      &   50*.0000D+00,
31247      &   .3000D+00, .3000D+00, .3000D+00  /
31248       DATA ( GA ( I ), I = 184,210 ) /
31249      & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31250      & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31251      & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31252      & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31253      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31254      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31255      & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31256      & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31257      & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31258 * Particle  names
31259 * S+1385+Sigma+(1385)    L02030+Lambda0(2030)
31260 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31261 * designation N*@@ means N*@1(@2)
31262       DATA (ANAME(K),K=1,85) /
31263      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31264      &  'ANUE    ','GAM     ','NEU     ','ANEU    ','MUE+    ',
31265      &  'MUE-    ','K0L     ','PI+     ','PI-     ','K+      ',
31266      &  'K-      ','LAM     ','ALAM    ','K0S     ','SIGM-   ',
31267      &  'SIGM+   ','SIGM0   ','PI0     ','K0      ','AK0     ',
31268      &  'BLANK   ','BLANK   ','BLANK   ','BLANK   ','BLANK   ',
31269      &  'ETA550  ','RHO+77  ','RHO077  ','RHO-77  ','OM0783  ',
31270      &  'K*+892  ','K*0892  ','K*-892  ','AK*089  ','KA+125  ',
31271      &  'KA0125  ','KA-125  ','AKA012  ','K*+142  ','K*0142  ',
31272      &  'K*-142  ','AK*014  ','S+1385  ','S01385  ','S-1385  ',
31273      &  'L01820  ','L02030  ','N*++12  ','N*+ 12  ','N*012   ',
31274      &  'N*-12   ','N*++16  ','N*+16   ','N*016   ','N*-16   ',
31275      &  'N*+14   ','N*014   ','N*+15   ','N*015   ','N*+18   ',
31276      &  'N*018   ','AN--12  ','AN*-12  ','AN*012  ','AN*+12  ',
31277      &  'AN--16  ','AN*-16  ','AN*016  ','AN*+16  ','AN*-15  ',
31278      &  'AN*015  ','DE*=24  ','RPI+49  ','RPI049  ','RPI-49  ',
31279      &  'PIN++   ','PIN+0   ','PIN+-   ','PIN-0   ','PPPI    ' /
31280       DATA (ANAME(K),K=86,183) /
31281      &  'PNPI    ','APPPI   ','APNPI   ','K+PPI   ','K-PPI   ',
31282      &  'K+NPI   ','K-NPI   ','S+1820  ','S-2030  ','ETA*    ',
31283      &  'PHI     ','TETA0   ','TETA-   ','ASIG-   ','ASIG0   ',
31284      &  'ASIG+   ','ATETA0  ','ATETA+  ','SIG*+   ','SIG*0   ',
31285      &  'SIG*-   ','TETA*0  ','TETA*   ','OMEGA-  ','ASIG*-  ',
31286      &  'ASIG*0  ','ASIG*+  ','ATET*0  ','ATET*+  ','OMEGA+  ',
31287      &  'D0      ','D+      ','D-      ','AD0     ','F+      ',
31288      &  'F-      ','ETAC    ','D*0     ','D*+     ','D*-     ',
31289      &  'AD*0    ','F*+     ','F*-     ','PSI     ','JPSI    ',
31290      &  'TAU+    ','TAU-    ','NUET    ','ANUET   ','NUEM    ',
31291      &  'ANUEM   ','C0+     ','A+      ','A0      ','C1++    ',
31292      &  'C1+     ','C10     ','S+      ','S0      ','T0      ',
31293      &  'XU++    ','XD+     ','XS+     ','AC0-    ','AA-     ',
31294      &  'AA0     ','AC1--   ','AC1-    ','AC10    ','AS-     ',
31295      &  'AS0     ','AT0     ','AXU--   ','AXD-    ','AXS     ',
31296      &  'C1*++   ','C1*+    ','C1*0    ','S*+     ','S*0     ',
31297      &  'T*0     ','XU*++   ','XD*+    ','XS*+    ','TETA++  ',
31298      &  'AC1*--  ','AC1*-   ','AC1*0   ','AS*-    ','AS*0    ',
31299      &  'AT*0    ','AXU*--  ','AXD*-   ','AXS*-   ','ATET--  ',
31300      &  'RO      ','R+      ','R-      '  /
31301       DATA (    ANAME ( I ), I = 184,210 ) /
31302      &'AN*-14  ','AN*014  ','PI+130  ','PI0130  ','PI-130  ','F01400  ',
31303      &'K*+146  ','K*-146  ','K*0146  ','AK0146  ','L01600  ','AL0160  ',
31304      &'S+1660  ','S01660  ','S-1660  ','AS-166  ','AS0166  ','AS+166  ',
31305      &'X01950  ','X-1950  ','AX0195  ','AX+195  ','OM-225  ','AOM+22  ',
31306      &'N*+14   ','N*014   ','BLANK   '/
31307 * Charge of particles and resonances
31308       DATA (IICH ( I ), I =   1,210 ) /
31309      &  1, -1, -1,  1,  0,  0,  0,  0,  0,  1, -1,  0,  1, -1,  1,
31310      & -1,  0,  0,  0, -1,  1,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31311      &  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0,
31312      & -1,  0,  1,  0, -1,  0,  0,  2,  1,  0, -1,  2,  1,  0, -1,
31313      &  1,  0,  1,  0,  1,  0, -2, -1,  0,  1, -2, -1,  0,  1, -1,
31314      &  0,  1,  1,  0, -1,  2,  1,  0, -1,  2,  1,  0, -1,  2,  0,
31315      &  1, -1,  1, -1,  0,  0,  0, -1, -1,  0,  1,  0,  1,  1,  0,
31316      & -1,  0, -1, -1, -1,  0,  1,  0,  1,  1,  0,  1, -1,  0,  1,
31317      & -1,  0,  0,  1, -1,  0,  1, -1,  0,  0,  1, -1,  0,  0,  0,
31318      &  0,  1,  1,  0,  2,  1,  0,  1,  0,  0,  2,  1,  1, -1, -1,
31319      &  0, -2, -1,  0, -1,  0,  0, -2, -1, -1,  2,  1,  0,  1,  0,
31320      &  0,  2,  1,  1,  2, -2, -1,  0, -1,  0,  0, -2, -1, -1, -2,
31321      &  0,  1, -1, -1,  0,  1,  0, -1,  0,  1, -1,  0,  0,  0,  0,
31322      &  1,  0, -1, -1,  0,  1,  0, -1,  0,  1, -1,  1,  1,  0,  0/
31323 * Particle  baryonic charges
31324       DATA (IIBAR ( I ), I =   1,210 ) /
31325      &  1, -1,  0,  0,  0,  0,  0,  1, -1,  0,  0,  0,  0,  0,  0,
31326      &  0,  1, -1,  0,  1,  1,  1,  0,  0,  0,  0,  0,  0,  0,  0,
31327      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31328      &  0,  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
31329      &  1,  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31330      & -1,  2,  0,  0,  0,  1,  1,  1,  1,  2,  2,  0,  0,  1,  1,
31331      &  1,  1,  1,  1,  0,  0,  1,  1, -1, -1, -1, -1, -1,  1,  1,
31332      &  1,  1,  1,  1, -1, -1, -1, -1, -1, -1,  0,  0,  0,  0,  0,
31333      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31334      &  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1, -1, -1,
31335      & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,  1,  1,  1,  1,  1,
31336      &  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31337      &  0,  0,  0, -1, -1,  0,  0,  0,  0,  0,  0,  0,  0,  1, -1,
31338      &  1,  1,  1, -1, -1, -1,  1,  1, -1, -1,  1, -1,  1,  1,  0/
31339 * First number of decay channels used for resonances
31340 * and decaying particles
31341       DATA K1/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 16, 17,
31342      &  18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31343      &   2*330, 46, 51, 52, 54, 55, 58,
31344 *                                                             50
31345      &  60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31346      & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31347      & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31348 *                                         85
31349      & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31350      & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31351      & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31352      & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31353      & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31354      & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31355      & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31356      & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31357      & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31358      & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31359      & 590, 596, 602 /
31360 * Last number of decay channels used for resonances
31361 * and decaying particles
31362       DATA K2/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 15, 16, 17,
31363      & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31364      & 2* 330, 50, 51, 53, 54, 57,
31365 *                                                                 50
31366      & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31367      & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31368      & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31369 *                                              85
31370      & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31371      & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31372      & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31373      & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31374      & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31375      & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31376      & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31377      & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31378      & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31379      & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31380      & 589, 595, 601, 602 /
31381
31382        END
31383
31384 *$ CREATE DT_BLKD47.FOR
31385 *COPY DT_BLKD47
31386 *
31387 *===blkd47=============================================================*
31388 *
31389       BLOCK DATA DT_BLKD47
31390
31391       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31392       SAVE
31393
31394 * HADRIN: decay channel information
31395       PARAMETER (IDMAX9=602)
31396       CHARACTER*8 ZKNAME
31397       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31398
31399 * Name of decay channel
31400 * Designation N*@ means N*@1(1236)
31401 * @1=# means ++,  @1 = = means --
31402 * Designation  P+/0/- means Pi+/Pi0/Pi- , respectively
31403       DATA (ZKNAME(K),K=  1, 85) /
31404      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31405      &  'ANUE    ','GAM     ','PE-NUE  ','APEANU  ','EANUNU  ',
31406      &  'E-NUAN  ','3PI0    ','PI+-0   ','PIMUNU  ','PIE-NU  ',
31407      &  'MU+NUE  ','MU-NUE  ','MU+NUE  ','PI+PI0  ','PI++-   ',
31408      &  'PI+00   ','M+P0NU  ','E+P0NU  ','MU-NU   ','PI-0    ',
31409      &  'PI+--   ','PI-00   ','M-P0NU  ','E-P0NU  ','PPI-    ',
31410      &  'NPI0    ','PD-NUE  ','PM-NUE  ','APPI+   ','ANPI0   ',
31411      &  'APE+NU  ','APM+NU  ','PI+PI-  ','PI0PI0  ','NPI-    ',
31412      &  'PPI0    ','NPI+    ','LAGA    ','GAGA    ','GAE+E-  ',
31413      &  'GAGA    ','GAGAP0  ','PI000   ','PI+-0   ','PI+-GA  ',
31414      &  'PI+0    ','PI+-    ','PI00    ','PI-0    ','PI+-0   ',
31415      &  'PI+-    ','PI0GA   ','K+PI0   ','K0PI+   ','KOPI0   ',
31416      &  'K+PI-   ','K-PI0   ','AK0PI-  ','AK0PI0  ','K-PI+   ',
31417      &  'K+PI0   ','K0PI+   ','K0PI0   ','K+PI-   ','K-PI0   ',
31418      &  'K0PI-   ','AK0PI0  ','K-PI+   ','K+PI0   ','K0PI+   ',
31419      &  'K+89P0  ','K08PI+  ','K+RO77  ','K0RO+7  ','K+OM07  ',
31420      &  'K+E055  ','K0PI0   ','K+PI+   ','K089P0  ','K+8PI-  '  /
31421       DATA (ZKNAME(K),K= 86,170) /
31422      &  'K0R077  ','K+R-77  ','K+R-77  ','K0OM07  ','K0E055  ',
31423      &  'K-PI0   ','K0PI-   ','K-89P0  ','AK08P-  ','K-R077  ',
31424      &  'AK0R-7  ','K-OM07  ','K-E055  ','AK0PI0  ','K-PI+   ',
31425      &  'AK08P0  ','K-8PI+  ','AK0R07  ','AK0OM7  ','AK0E05  ',
31426      &  'LA0PI+  ','SI0PI+  ','SI+PI0  ','LA0PI0  ','SI+PI-  ',
31427      &  'SI-PI+  ','LA0PI-  ','SI0PI-  ','NEUAK0  ','PK-     ',
31428      &  'SI+PI-  ','SI0PI0  ','SI-PI+  ','LA0ET0  ','S+1PI-  ',
31429      &  'S-1PI+  ','SO1PI0  ','NEUAK0  ','PK-     ','LA0PI0  ',
31430      &  'LA0OM0  ','LA0RO0  ','SI+RO-  ','SI-RO+  ','SI0RO0  ',
31431      &  'LA0ET0  ','SI0ET0  ','SI+PI-  ','SI-PI+  ','SI0PI0  ',
31432      &  'K0S     ','K0L     ','K0S     ','K0L     ','P PI+   ',
31433      &  'P PI0   ','N PI+   ','P PI-   ','N PI0   ','N PI-   ',
31434      &  'P PI+   ','N*#PI0  ','N*+PI+  ','PRHO+   ','P PI0   ',
31435      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31436      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31437      &  'N*-PI+  ','PRHO-   ','NRHO0   ','N PI-   ','N*0PI-  ',
31438      &  'N*-PI0  ','NRHO-   ','PETA0   ','N*#PI-  ','N*+PI0  '  /
31439       DATA (ZKNAME(K),K=171,255) /
31440      &  'N*0PI+  ','PRHO0   ','NRHO+   ','NETA0   ','N*+PI-  ',
31441      &  'N*0PI0  ','N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ',
31442      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31443      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31444      &  'N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ','N PI+   ',
31445      &  'PRHO0   ','NRHO+   ','LAMK+   ','S+ K0   ','S0 K+   ',
31446      &  'PETA0   ','P PI-   ','N PI0   ','PRHO-   ','NRHO0   ',
31447      &  'LAMK0   ','S0 K0   ','S- K+   ','NETA/   ','APPI-   ',
31448      &  'APPI0   ','ANPI-   ','APPI+   ','ANPI0   ','ANPI+   ',
31449      &  'APPI-   ','AN*=P0  ','AN*-P-  ','APRHO-  ','APPI0   ',
31450      &  'ANPI-   ','AN*=P+  ','AN*-P0  ','AN*0P-  ','APRHO0  ',
31451      &  'ANRHO-  ','APPI+   ','ANPI0   ','AN*-P+  ','AN*0P0  ',
31452      &  'AN*+P-  ','APRHO+  ','ANRHO0  ','ANPI+   ','AN*0P+  ',
31453      &  'AN*+P0  ','ANRHO+  ','APPI0   ','ANPI-   ','AN*=P+  ',
31454      &  'AN*-P0  ','AN*0P-  ','APRHO0  ','ANRHO-  ','APPI+,  ',
31455      &  'ANPI0   ','AN*-P+  ','AN*0P0  ','AN*+P-  ','APRHO+  ',
31456      &  'ANRHO0  ','PN*014  ','NN*=14  ','PI+0    ','PI+-    '  /
31457       DATA (ZKNAME(K),K=256,340) /
31458      &  'PI-0    ','P+0     ','N++     ','P+-     ','P00     ',
31459      &  'N+0     ','N+-     ','N00     ','P-0     ','N-0     ',
31460      &  'P--     ','PPPI0   ','PNPI+   ','PNPI0   ','PPPI-   ',
31461      &  'NNPI+   ','APPPI0  ','APNPI+  ','ANNPI0  ','ANPPI-  ',
31462      &  'APNPI0  ','APPPI-  ','ANNPI-  ','K+PPI0  ','K+NPI+  ',
31463      &  'K0PPI0  ','K-PPI0  ','K-NPI+  ','AKPPI-  ','AKNPI0  ',
31464      &  'K+NPI0  ','K+PPI-  ','K0PPI0  ','K0NPI+  ','K-NPI0  ',
31465      &  'K-PPI-  ','AKNPI-  ','PAK0    ','SI+PI0  ','SI0PI+  ',
31466      &  'SI+ETA  ','S+1PI0  ','S01PI+  ','NEUK-   ','LA0PI-  ',
31467      &  'SI-OM0  ','LA0RO-  ','SI0RO-  ','SI-RO0  ','SI-ET0  ',
31468      &  'SI0PI-  ','SI-0    ','BLANC   ','BLANC   ','BLANC   ',
31469      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31470      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31471      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31472      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31473      &  'EPI+-   ','EPI00   ','GAPI+-  ','GAGA*   ','K+-     ',
31474      &  'KLKS    ','PI+-0   ','EGA     ','LPI0    ','LPI     '  /
31475       DATA (ZKNAME(K),K=341,425) /
31476      &  'APPI0   ','ANPI-   ','ALAGA   ','ANPI    ','ALPI0   ',
31477      &  'ALPI+   ','LAPI+   ','SI+PI0  ','SI0PI+  ','LAPI0   ',
31478      &  'SI+PI-  ','SI-PI+  ','LAPI-   ','SI-PI0  ','SI0PI-  ',
31479      &  'TE0PI0  ','TE-PI+  ','TE0PI-  ','TE-PI0  ','TE0PI   ',
31480      &  'TE-PI   ','LAK-    ','ALPI-   ','AS-PI0  ','AS0PI-  ',
31481      &  'ALPI0   ','AS+PI-  ','AS-PI+  ','ALPI+   ','AS+PI0  ',
31482      &  'AS0PI+  ','AT0PI0  ','AT+PI-  ','AT0PI+  ','AT+PI0  ',
31483      &  'AT0PI   ','AT+PI   ','ALK+    ','K-PI+   ','K-PI+0  ',
31484      &  'K0PI+-  ','K0PI0   ','K-PI++  ','AK0PI+  ','K+PI--  ',
31485      &  'K0PI-   ','K+PI-   ','K+PI-0  ','AKPI-+  ','AK0PI0  ',
31486      &  'ETAPIF  ','K++-    ','K+AK0   ','ETAPI-  ','K--+    ',
31487      &  'K-K0    ','PI00    ','PI+-    ','GAGA    ','D0PI0   ',
31488      &  'D0GA    ','D0PI+   ','D+PI0   ','DFGA    ','AD0PI-  ',
31489      &  'D-PI0   ','D-GA    ','AD0PI0  ','AD0GA   ','F+GA    ',
31490      &  'F+GA    ','F-GA    ','F-GA    ','PSPI+-  ','PSPI00  ',
31491      &  'PSETA   ','E+E-    ','MUE+-   ','PI+-0   ','M+NN    ',
31492      &  'E+NN    ','RHO+NT  ','PI+ANT  ','K*+ANT  ','M-NN    '  /
31493       DATA (ZKNAME(K),K=426,510) /
31494      &  'E-NN    ','RHO-NT  ','PI-NT   ','K*-NT   ','NUET    ',
31495      &  'ANUET   ','NUEM    ','ANUEM   ','SI+ETA  ','SI+ET*  ',
31496      &  'PAK0    ','TET0K+  ','SI*+ET  ','N*+AK0  ','N*++K-  ',
31497      &  'LAMRO+  ','SI0RO+  ','SI+RO0  ','SI+OME  ','PAK*0   ',
31498      &  'N*+AK*  ','N*++K*  ','SI+AK0  ','TET0PI  ','SI+AK*  ',
31499      &  'TET0RO  ','SI0AK*  ','SI+K*-  ','TET0OM  ','TET-RO  ',
31500      &  'SI*0AK  ','C0+PI+  ','C0+PI0  ','C0+PI-  ','A+GAM   ',
31501      &  'A0GAM   ','TET0AK  ','TET0K*  ','OM-RO+  ','OM-PI+  ',
31502      &  'C1++AK  ','A+PI+   ','C0+AK0  ','A0PI+   ','A+AK0   ',
31503      &  'T0PI+   ','ASI-ET  ','ASI-E*  ','APK0    ','ATET0K  ',
31504      &  'ASI*-E  ','AN*-K0  ','AN*--K  ','ALAMRO  ','ASI0RO  ',
31505      &  'ASI-RO  ','ASI-OM  ','APK*0   ','AN*-K*  ','AN*--K  ',
31506      &  'ASI-K0  ','ATETPI  ','ASI-K*  ','ATETRO  ','ASI0K*  ',
31507      &  'ASI-K*  ','ATE0OM  ','ATE+RO  ','ASI*0K  ','AC-PI-  ',
31508      &  'AC-PI0  ','AC-PI+  ','AA-GAM  ','AA0GAM  ','ATET0K  ',
31509      &  'ATE0K*  ','AOM+RO  ','AOM+PI  ','AC1--K  ','AA-PI-  ',
31510      &  'AC0-K0  ','AA0PI-  ','AA-K0   ','AT0PI-  ','C1++GA  '  /
31511       DATA (ZKNAME(K),K=511,540) /
31512      &  'C1++GA  ','C10GAM  ','S+GAM   ','S0GAM   ','T0GAM   ',
31513      &  'XU++GA  ','XD+GAM  ','XS+GAM  ','A+AKPI  ','T02PI+  ',
31514      &  'C1++2K  ','AC1--G  ','AC1-GA  ','AC10GA  ','AS-GAM  ',
31515      &  'AS0GAM  ','AT0GAM  ','AXU--G  ','AXD-GA  ','AXS-GA  ',
31516      &  'AA-KPI  ','AT02PI  ','AC1--K  ','RH-PI+  ','RH+PI-  ',
31517      &  'RH3PI0  ','RH0PI+  ','RH+PI0  ','RH0PI-  ','RH-PI0  '  /
31518       DATA (ZKNAME(I),I=541,602)/
31519      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31520      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31521      & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31522      & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31523      & 'PI+PI-','K+K-  ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31524      & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31525      & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31526      & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31527      & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31528 * Weight of decay channel
31529       DATA (WT(K),K=  1, 85) /
31530      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31531      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31532      &   .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31533      &   .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31534      &   .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31535      &   .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31536      &   .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31537      &   .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31538      &   .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31539      &   .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31540      &   .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31541      &   .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31542      &   .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31543      &   .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31544      &   .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31545      &   .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31546      &   .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00  /
31547       DATA (WT(K),K= 86,170) /
31548      &   .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31549      &   .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31550      &   .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31551      &   .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31552      &   .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31553      &   .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31554      &   .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31555      &   .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31556      &   .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31557      &   .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31558      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31559      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31560      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31561      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31562      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31563      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31564      &   .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00  /
31565       DATA (WT(K),K=171,255) /
31566      &   .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31567      &   .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31568      &   .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31569      &   .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31570      &   .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31571      &   .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31572      &   .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31573      &   .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31574      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31575      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31576      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31577      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31578      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31579      &   .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31580      &   .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31581      &   .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31582      &   .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01  /
31583       DATA (WT(K),K=256,340) /
31584      &   .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31585      &   .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31586      &   .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31587      &   .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31588      &   .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31589      &   .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31590      &   .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31591      &   .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31592      &   .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31593      &   .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31594      &   .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31595      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31596      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31597      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31598      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31599      &   .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31600      &   .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01  /
31601       DATA (WT(K),K=341,425) /
31602      &   .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31603      &   .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31604      &   .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31605      &   .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31606      &   .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31607      &   .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31608      &   .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31609      &   .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31610      &   .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31611      &   .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31612      &   .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31613      &   .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31614      &   .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31615      &   .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31616      &   .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31617      &   .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31618      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00  /
31619       DATA (WT(K),K=426,510) /
31620      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31621      &   .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31622      &   .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31623      &   .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31624      &   .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31625      &   .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31626      &   .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31627      &   .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31628      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31629      &   .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31630      &   .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31631      &   .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31632      &   .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31633      &   .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31634      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31635      &   .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31636      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01  /
31637       DATA (WT(K),K=511,540) /
31638      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31639      &   .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31640      &   .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31641      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31642      &   .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31643      &   .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00  /
31644 C
31645       DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31646      & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31647      & .125D+00,  0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31648      & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31649      & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31650      & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31651      & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31652 * Particle numbers in decay channel
31653       DATA (NZK(K,1),K=  1,170) /
31654      &     1,   2,   3,   4,   5,   6,   7,   1,   2,   4,
31655      &     3,  23,  13,  13,  13,  10,  11,  10,  13,  13,
31656      &    13,  10,   4,  11,  14,  14,  14,  11,   3,   1,
31657      &     8,   1,   1,   2,   9,   2,   2,  13,  23,   8,
31658      &     1,   8,  17,   7,   7,   7,  23,  23,  13,  13,
31659      &    13,  13,  23,  14,  13,  13,  23,  15,  24,  24,
31660      &    15,  16,  25,  25,  16,  15,  24,  24,  15,  16,
31661      &    24,  25,  16,  15,  24,  36,  37,  15,  24,  15,
31662      &    15,  24,  15,  37,  36,  24,  15,  24,  24,  16,
31663      &    24,  38,  39,  16,  25,  16,  16,  25,  16,  39,
31664      &    38,  25,  16,  25,  25,  17,  22,  21,  17,  21,
31665      &    20,  17,  22,   8,   1,  21,  22,  20,  17,  48,
31666      &    50,  49,   8,   1,  17,  17,  17,  21,  20,  22,
31667      &    17,  22,  21,  20,  22,  19,  12,  19,  12,   1,
31668      &     1,   8,   1,   8,   8,   1,  53,  54,   1,   1,
31669      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31670      &    56,   1,   8,   8,  55,  56,   8,   1,  53,  54  /
31671       DATA (NZK(K,1),K=171,340) /
31672      &    55,   1,   8,   8,  54,  55,  56,   1,   8,   1,
31673      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31674      &    56,   1,   8,   1,   8,   1,   8,  17,  21,  22,
31675      &     1,   1,   8,   1,   8,  17,  22,  20,   8,   2,
31676      &     2,   9,   2,   9,   9,   2,  67,  68,   2,   2,
31677      &     9,  67,  68,  69,   2,   9,   2,   9,  68,  69,
31678      &    70,   2,   9,   9,  69,  70,   9,   2,   9,  67,
31679      &    68,  69,   2,   9,   2,   9,  68,  69,  70,   2,
31680      &     9,   1,   8,  13,  13,  14,   1,   8,   1,   1,
31681      &     8,   8,   8,   1,   8,   1,   1,   1,   1,   1,
31682      &     8,   2,   2,   9,   9,   2,   2,   9,  15,  15,
31683      &    24,  16,  16,  25,  25,  15,  15,  24,  24,  16,
31684      &    16,  25,   1,  21,  22,  21,  48,  49,   8,  17,
31685      &    20,  17,  22,  20,  20,  22,  20,   0,   0,   0,
31686      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31687      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31688      &    31,  31,  13,   7,  15,  12,  13,  31,  17,  17  /
31689       DATA (NZK(K,1),K=341,510) /
31690      &     2,   9,  18,   9,  18,  18,  17,  21,  22,  17,
31691      &    21,  20,  17,  20,  22,  97,  98,  97,  98,  97,
31692      &    98,  17,  18,  99, 100,  18, 101,  99,  18, 101,
31693      &   100, 102, 103, 102, 103, 102, 103,  18,  16,  16,
31694      &    24,  24,  16,  25,  15,  24,  15,  15,  25,  25,
31695      &    31,  15,  15,  31,  16,  16,  23,  13,   7, 116,
31696      &   116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31697      &   120, 121, 121, 130, 130, 130,   4,  10,  13,  10,
31698      &     4,  32,  13,  36,  11,   3,  34,  14,  38, 133,
31699      &   134, 135, 136,  21,  21,   1,  97, 104,  54,  53,
31700      &    17,  22,  21,  21,   1,  54,  53,  21,  97,  21,
31701      &    97,  22,  21,  97,  98, 105, 137, 137, 137, 138,
31702      &   139,  97,  97, 109, 109, 140, 138, 137, 139, 138,
31703      &   145,  99,  99,   2, 102, 110,  68,  67,  18, 100,
31704      &    99,  99,   2,  68,  67,  99, 102,  99, 102, 100,
31705      &    99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31706      &   113, 115, 115, 152, 150, 149, 151, 150, 157, 140  /
31707       DATA (NZK(K,1),K=511,540) /
31708      &   141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31709      &   140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31710      &   150, 157, 152,  34,  32,  33,  33,  32,  33,  34  /
31711       DATA (NZK(I,1),I=541,602) /  2, 67, 68, 69,  2,  9,  9, 68, 69,
31712      & 70,  2,  9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31713      & 14, 189, 23, 13, 15, 24,  36,  38,  37,  39, 194, 195, 196, 197,
31714      & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31715      & 55, 8, 1, 8, 8, 54, 55, 210/
31716       DATA (NZK(K,2),K=  1,170) /
31717      &     0,   0,   0,   0,   0,   0,   0,   3,   4,   6,
31718      &     5,  23,  14,  11,   3,   5,   5,   5,  23,  13,
31719      &    23,  23,  23,   5,  23,  13,  23,  23,  23,  14,
31720      &    23,   3,  11,  13,  23,   4,  10,  14,  23,  14,
31721      &    23,  13,   7,   7,   4,   7,   7,  23,  14,  14,
31722      &    23,  14,  23,  23,  14,  14,   7,  23,  13,  23,
31723      &    14,  23,  14,  23,  13,  23,  13,  23,  14,  23,
31724      &    14,  23,  13,  23,  13,  23,  13,  33,  32,  35,
31725      &    31,  23,  14,  23,  14,  33,  34,  35,  31,  23,
31726      &    14,  23,  14,  33,  34,  35,  31,  23,  13,  23,
31727      &    13,  33,  32,  35,  31,  13,  13,  23,  23,  14,
31728      &    13,  14,  14,  25,  16,  14,  23,  13,  31,  14,
31729      &    13,  23,  25,  16,  23,  35,  33,  34,  32,  33,
31730      &    31,  31,  14,  13,  23,   0,   0,   0,   0,  13,
31731      &    23,  13,  14,  23,  14,  13,  23,  13,  78,  23,
31732      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31733      &    13,  80,  79,  14,  14,  23,  80,  31,  14,  23  /
31734       DATA (NZK(K,2),K=171,340) /
31735      &    13,  79,  78,  31,  14,  23,  13,  80,  79,  23,
31736      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31737      &    13,  80,  79,  23,  13,  33,  32,  15,  24,  15,
31738      &    31,  14,  23,  34,  33,  24,  24,  15,  31,  14,
31739      &    23,  14,  13,  23,  13,  14,  23,  14,  80,  23,
31740      &    14,  13,  23,  14,  79,  80,  13,  23,  13,  23,
31741      &    14,  78,  79,  13,  13,  23,  78,  23,  14,  13,
31742      &    23,  14,  79,  80,  13,  23,  13,  23,  14,  78,
31743      &    79,  62,  61,  23,  14,  23,  13,  13,  13,  23,
31744      &    13,  13,  23,  14,  14,  14,   1,   8,   8,   1,
31745      &     8,   1,   8,   8,   1,   8,   1,   8,   1,   8,
31746      &     1,   1,   8,   1,   8,   8,   1,   1,   8,   8,
31747      &     1,   8,  25,  23,  13,  31,  23,  13,  16,  14,
31748      &    35,  34,  34,  33,  31,  14,  23,   0,   0,   0,
31749      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31750      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31751      &    13,  23,  14,   7,  16,  19,  14,   7,  23,  14  /
31752       DATA (NZK(K,2),K=341,510) /
31753      &    23,  14,   7,  13,  23,  13,  13,  23,  13,  23,
31754      &    14,  13,  14,  23,  14,  23,  13,  14,  23,  14,
31755      &    23,  16,  14,  23,  14,  23,  14,  13,  13,  23,
31756      &    13,  23,  14,  13,  23,  13,  23,  15,  13,  13,
31757      &    13,  23,  13,  13,  14,  14,  14,  14,  14,  23,
31758      &    13,  16,  25,  14,  15,  24,  23,  14,   7,  23,
31759      &     7,  13,  23,   7,  14,  23,   7,  23,   7,   7,
31760      &     7,   7,   7,  13,  23,  31,   3,  11,  14, 135,
31761      &     5, 134, 134, 134, 136,   6, 133, 133, 133,   0,
31762      &     0,   0,   0,  31,  95,  25,  15,  31,  95,  16,
31763      &    32,  32,  33,  35,  39,  39,  38,  25,  13,  39,
31764      &    32,  39,  38,  35,  32,  39,  13,  23,  14,   7,
31765      &     7,  25,  37,  32,  13,  25,  13,  25,  13,  25,
31766      &    13,  31,  95,  24,  16,  31,  24,  15,  34,  34,
31767      &    33,  35,  37,  37,  36,  24,  14,  37,  34,  37,
31768      &    36,  35,  34,  37,  14,  23,  13,   7,   7,  24,
31769      &    39,  34,  14,  24,  14,  24,  14,  24,  14,   7  /
31770       DATA (NZK(K,2),K=511,540) /
31771      &     7,   7,   7,   7,   7,   7,   7,   7,  25,  13,
31772      &    25,   7,   7,   7,   7,   7,   7,   7,   7,   7,
31773      &    24,  14,  24,  13,  14,  23,  13,  23,  14,  23  /
31774       DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31775      & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31776      & 14, 14, 23, 14, 16, 25,
31777      & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31778      & 23, 13, 14, 23,  0 /
31779       DATA (NZK(K,3),K=  1,170) /
31780      &     0,   0,   0,   0,   0,   0,   0,   5,   6,   5,
31781      &     6,  23,  23,   5,   5,   0,   0,   0,   0,  14,
31782      &    23,   5,   5,   0,   0,  14,  23,   5,   5,   0,
31783      &     0,   5,   5,   0,   0,   5,   5,   0,   0,   0,
31784      &     0,   0,   0,   0,   3,   0,   7,  23,  23,   7,
31785      &     0,   0,   0,   0,  23,   0,   0,   0,   0,   0,
31786      &     110*0   /
31787       DATA (NZK(K,3),K=171,340) /
31788      &     80*0,
31789      &     0,   0,   0,   0,   0,   0,  23,  13,  14,  23,
31790      &    23,  14,  23,  23,  23,  14,  23,  13,  23,  14,
31791      &    13,  23,  13,  23,  14,  23,  14,  14,  23,  13,
31792      &    13,  23,  13,  14,  23,  23,  14,  23,  13,  23,
31793      &    14,  14,   0,   0,   0,   0,   0,   0,   0,   0,
31794      &     30*0,
31795      &    14,  23,   7,   0,   0,   0,  23,   0,   0,   0  /
31796       DATA (NZK(K,3),K=341,510) /
31797      &     30*0,
31798      &     0,   0,   0,   0,   0,   0,   0,   0,   0,  23,
31799      &    14,   0,  13,   0,  14,   0,   0,  23,  13,   0,
31800      &     0,  15,   0,   0,  16,   0,   0,   0,   0,   0,
31801      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31802      &     0,   0,   0,  14,  23,   0,   0,   0,  23, 134,
31803      &   134,   0,   0,   0, 133, 133,   0,   0,   0,   0,
31804      &     80*0  /
31805       DATA (NZK(K,3),K=511,540) /
31806      &     0,   0,   0,   0,   0,   0,   0,   0,  13,  13,
31807      &    25,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31808      &    14,  14,  24,   0,   0,   0,   0,   0,   0,   0  /
31809       DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31810      & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31811
31812       END
31813
31814 *$ CREATE DT_XHOINI.FOR
31815 *COPY DT_XHOINI
31816 *
31817 *====phoini============================================================*
31818 *
31819       SUBROUTINE DT_XHOINI
31820 C     SUBROUTINE DT_PHOINI
31821
31822       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31823       SAVE
31824
31825       PARAMETER ( LINP = 10 ,
31826      &            LOUT = 6 ,
31827      &            LDAT = 9 )
31828
31829       RETURN
31830       END
31831
31832 *$ CREATE DT_XVENTB.FOR
31833 *COPY DT_XVENTB
31834 *
31835 *====eventb============================================================*
31836 *
31837       SUBROUTINE DT_XVENTB(NCSY,IREJ)
31838 C     SUBROUTINE DT_EVENTB(NCSY,IREJ)
31839
31840       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31841       SAVE
31842
31843       PARAMETER ( LINP = 10 ,
31844      &            LOUT = 6 ,
31845      &            LDAT = 9 )
31846
31847       WRITE(LOUT,1000)
31848  1000 FORMAT(1X,'EVENTB:   PHOJET-package requested but not linked!')
31849       STOP
31850
31851       END
31852
31853 *$ CREATE DT_XVENT.FOR
31854 *COPY DT_XVENT
31855 *
31856 *===event==============================================================*
31857 *
31858       SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
31859 C     SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
31860
31861       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31862       SAVE
31863
31864       DIMENSION PP(4),PT(4)
31865
31866       RETURN
31867       END
31868
31869 *$ CREATE DT_XOHISX.FOR
31870 *COPY DT_XOHISX
31871 *
31872 *===pohisx=============================================================*
31873 *
31874       SUBROUTINE DT_XOHISX(I,X)
31875 C     SUBROUTINE POHISX(I,X)
31876
31877       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31878       SAVE
31879
31880       RETURN
31881       END
31882
31883 *$ CREATE PHO_LHIST.FOR
31884 *COPY PHO_LHIST
31885 *
31886 *===poluhi=============================================================*
31887 *
31888       SUBROUTINE PHO_LHIST(I,X)
31889
31890 **
31891
31892       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31893       SAVE
31894
31895       RETURN
31896       END
31897
31898 *$ CREATE PDFSET.FOR
31899 *COPY PDFSET
31900 *
31901 C**********************************************************************
31902 C
31903 C   dummy subroutines, remove to link PDFLIB
31904 C
31905 C**********************************************************************
31906       SUBROUTINE PDFSET(PARAM,VALUE)
31907       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31908       DIMENSION PARAM(20),VALUE(20)
31909       CHARACTER*20 PARAM
31910       END
31911
31912 *$ CREATE STRUCTM.FOR
31913 *COPY STRUCTM
31914 *
31915       SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31916       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31917       END
31918
31919 *$ CREATE STRUCTP.FOR
31920 *COPY STRUCTP
31921 *
31922       SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31923       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31924       END
31925
31926 *$ CREATE DT_DIQBRK.FOR
31927 *COPY DT_DIQBRK
31928 *
31929 *===diqbrk=============================================================*
31930 *
31931       SUBROUTINE DT_XIQBRK
31932 C     SUBROUTINE DT_DIQBRK
31933
31934       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31935       SAVE
31936
31937       STOP 'diquark-breaking not implemeted !'
31938
31939       RETURN
31940       END
31941 *$ CREATE DT_ELHAIN.FOR
31942 *COPY DT_ELHAIN
31943 *
31944 *===elhain=============================================================*
31945 *
31946       SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
31947
31948 ************************************************************************
31949 * Elastic hadron-hadron scattering.                                    *
31950 * This is a revised version of the original.                           *
31951 * This version dated 03.04.98 is written by S. Roesler                 *
31952 ************************************************************************
31953
31954       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31955       SAVE
31956
31957       PARAMETER ( LINP = 10 ,
31958      &            LOUT = 6 ,
31959      &            LDAT = 9 )
31960
31961       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
31962      &           TINY10=1.0D-10)
31963
31964       PARAMETER (ENNTHR = 3.5D0)
31965       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
31966      &           BLOWB=0.05D0,BHIB=0.2D0,
31967      &           BLOWM=0.1D0, BHIM=2.0D0)
31968
31969 * particle properties (BAMJET index convention)
31970       CHARACTER*8  ANAME
31971       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31972      &                IICH(210),IIBAR(210),K1(210),K2(210)
31973
31974 * final state from HADRIN interaction
31975       PARAMETER (MAXFIN=10)
31976       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
31977      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
31978
31979 C     DATA TSLOPE /10.0D0/
31980
31981       IREJ = 0
31982
31983     1 CONTINUE
31984
31985       PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
31986       EKIN = ELAB-AAM(IP)
31987 *   kinematical quantities in cms of the hadrons
31988       AMP2 = AAM(IP)**2
31989       AMT2 = AAM(IT)**2
31990       S    = AMP2+AMT2+TWO*ELAB*AAM(IT)
31991       ECM  = SQRT(S)
31992       ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
31993       PCM  = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
31994
31995 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
31996       IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
31997      &     ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
31998 *   TSAMCS treats pp and np only, therefore change pn into np and
31999 *   nn into pp
32000          IF (IT.EQ.1) THEN
32001             KPROJ = IP
32002          ELSE
32003             KPROJ = 8
32004             IF (IP.EQ.8) KPROJ = 1
32005          ENDIF
32006          CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
32007          T = TWO*PCM**2*(CTCMS-ONE)
32008
32009 * very crude treatment otherwise: sample t from exponential dist.
32010       ELSE
32011 *   momentum transfer t
32012          TMAX = TWO*TWO*PCM**2
32013          RR = (PLAB-PLOWH)/(PHIH-PLOWH)
32014          IF (IIBAR(IP).NE.0) THEN
32015             TSLOPE = BLOWB+RR*(BHIB-BLOWB)
32016          ELSE
32017             TSLOPE = BLOWM+RR*(BHIM-BLOWM)
32018          ENDIF
32019          FMAX = EXP(-TSLOPE*TMAX)-ONE
32020          R = DT_RNDM(RR)
32021          T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
32022          IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
32023       ENDIF
32024
32025 *   target hadron in Lab after scattering
32026       ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
32027       PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
32028       IF (PLRH(2).LE.TINY10) THEN
32029 C        WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
32030          GOTO 1
32031       ENDIF
32032 *   projectile hadron in Lab after scattering
32033       ELRH(1) = ELAB+AAM(IT)-ELRH(2)
32034       PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
32035 *   scattering angle of projectile in Lab
32036       CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
32037       STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
32038       CALL DT_DSFECF(SPLABP,CPLABP)
32039 *   direction cosines of projectile in Lab
32040       CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
32041      &                          CXRH(1),CYRH(1),CZRH(1))
32042 *   scattering angle of target in Lab
32043       PLLABT = PLAB-CTLABP*PLRH(1)
32044       CTLABT = PLLABT/PLRH(2)
32045       STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
32046 *   direction cosines of target in Lab
32047       CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
32048      &                            CXRH(2),CYRH(2),CZRH(2))
32049 *   fill /HNFSPA/
32050       IRH = 2
32051       ITRH(1) = IP
32052       ITRH(2) = IT
32053
32054       RETURN
32055       END
32056
32057 *$ CREATE DT_TSAMCS.FOR
32058 *COPY DT_TSAMCS
32059 *
32060 *===tsamcs=============================================================*
32061 *
32062       SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
32063
32064 ************************************************************************
32065 * Sampling of cos(theta) for nucleon-proton scattering according to    *
32066 * hetkfa2/bertini parametrization.                                     *
32067 * This is a revised version of the original (HJM 24/10/88)             *
32068 * This version dated 28.10.95 is written by S. Roesler                 *
32069 ************************************************************************
32070
32071       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32072       SAVE
32073
32074       PARAMETER ( LINP = 10 ,
32075      &            LOUT = 6 ,
32076      &            LDAT = 9 )
32077
32078       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
32079      &           TINY10=1.0D-10)
32080
32081       DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
32082       DIMENSION PDCI(60),PDCH(55)
32083
32084       DATA (DCLIN(I),I=1,80) /
32085      &     5.000D-01,  1.000D+00,  0.000D+00,  1.000D+00,  0.000D+00,
32086      &     4.993D-01,  9.881D-01,  5.963D-02,  9.851D-01,  5.945D-02,
32087      &     4.936D-01,  8.955D-01,  5.224D-01,  8.727D-01,  5.091D-01,
32088      &     4.889D-01,  8.228D-01,  8.859D-01,  7.871D-01,  8.518D-01,
32089      &     4.874D-01,  7.580D-01,  1.210D+00,  7.207D-01,  1.117D+00,
32090      &     4.912D-01,  6.969D-01,  1.516D+00,  6.728D-01,  1.309D+00,
32091      &     5.075D-01,  6.471D-01,  1.765D+00,  6.667D-01,  1.333D+00,
32092      &     5.383D-01,  6.054D-01,  1.973D+00,  7.059D-01,  1.176D+00,
32093      &     5.397D-01,  5.990D-01,  2.005D+00,  7.023D-01,  1.191D+00,
32094      &     5.336D-01,  6.083D-01,  1.958D+00,  6.959D-01,  1.216D+00,
32095      &     5.317D-01,  6.075D-01,  1.962D+00,  6.897D-01,  1.241D+00,
32096      &     5.300D-01,  6.016D-01,  1.992D+00,  6.786D-01,  1.286D+00,
32097      &     5.281D-01,  6.063D-01,  1.969D+00,  6.786D-01,  1.286D+00,
32098      &     5.280D-01,  5.960D-01,  2.020D+00,  6.667D-01,  1.333D+00,
32099      &     5.273D-01,  5.920D-01,  2.040D+00,  6.604D-01,  1.358D+00,
32100      &     5.273D-01,  5.862D-01,  2.069D+00,  6.538D-01,  1.385D+00/
32101       DATA (DCLIN(I),I=81,160) /
32102      &     5.223D-01,  5.980D-01,  2.814D+00,  6.538D-01,  1.385D+00,
32103      &     5.202D-01,  5.969D-01,  2.822D+00,  6.471D-01,  1.412D+00,
32104      &     5.183D-01,  5.881D-01,  2.883D+00,  6.327D-01,  1.469D+00,
32105      &     5.159D-01,  5.866D-01,  2.894D+00,  6.250D-01,  1.500D+00,
32106      &     5.133D-01,  5.850D-01,  2.905D+00,  6.170D-01,  1.532D+00,
32107      &     5.106D-01,  5.833D-01,  2.917D+00,  6.087D-01,  1.565D+00,
32108      &     5.084D-01,  5.801D-01,  2.939D+00,  6.000D-01,  1.600D+00,
32109      &     5.063D-01,  5.763D-01,  2.966D+00,  5.909D-01,  1.636D+00,
32110      &     5.036D-01,  5.730D-01,  2.989D+00,  5.814D-01,  1.674D+00,
32111      &     5.014D-01,  5.683D-01,  3.022D+00,  5.714D-01,  1.714D+00,
32112      &     4.986D-01,  5.641D-01,  3.051D+00,  5.610D-01,  1.756D+00,
32113      &     4.964D-01,  5.580D-01,  3.094D+00,  5.500D-01,  1.800D+00,
32114      &     4.936D-01,  5.573D-01,  3.099D+00,  5.431D-01,  1.827D+00,
32115      &     4.909D-01,  5.509D-01,  3.144D+00,  5.313D-01,  1.875D+00,
32116      &     4.885D-01,  5.512D-01,  3.142D+00,  5.263D-01,  1.895D+00,
32117      &     4.857D-01,  5.437D-01,  3.194D+00,  5.135D-01,  1.946D+00/
32118       DATA (DCLIN(I),I=161,195) /
32119      &     4.830D-01,  5.353D-01,  3.253D+00,  5.000D-01,  2.000D+00,
32120      &     4.801D-01,  5.323D-01,  3.274D+00,  4.915D-01,  2.034D+00,
32121      &     4.770D-01,  5.228D-01,  3.341D+00,  4.767D-01,  2.093D+00,
32122      &     4.738D-01,  5.156D-01,  3.391D+00,  4.643D-01,  2.143D+00,
32123      &     4.701D-01,  5.010D-01,  3.493D+00,  4.444D-01,  2.222D+00,
32124      &     4.672D-01,  4.990D-01,  3.507D+00,  4.375D-01,  2.250D+00,
32125      &     4.634D-01,  4.856D-01,  3.601D+00,  4.194D-01,  2.323D+00/
32126
32127       DATA PDCI /
32128      &     4.400D+02,  1.896D-01,  1.931D-01,  1.982D-01,  1.015D-01,
32129      &     1.029D-01,  4.180D-02,  4.228D-02,  4.282D-02,  4.350D-02,
32130      &     2.204D-02,  2.236D-02,  5.900D+02,  1.433D-01,  1.555D-01,
32131      &     1.774D-01,  1.000D-01,  1.128D-01,  5.132D-02,  5.600D-02,
32132      &     6.158D-02,  6.796D-02,  3.660D-02,  3.820D-02,  6.500D+02,
32133      &     1.192D-01,  1.334D-01,  1.620D-01,  9.527D-02,  1.141D-01,
32134      &     5.283D-02,  5.952D-02,  6.765D-02,  7.878D-02,  4.796D-02,
32135      &     6.957D-02,  8.000D+02,  4.872D-02,  6.694D-02,  1.152D-01,
32136      &     9.348D-02,  1.368D-01,  6.912D-02,  7.953D-02,  9.577D-02,
32137      &     1.222D-01,  7.755D-02,  9.525D-02,  1.000D+03,  3.997D-02,
32138      &     5.456D-02,  9.804D-02,  8.084D-02,  1.208D-01,  6.520D-02,
32139      &     8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,  1.093D-01/
32140
32141       DATA PDCH /
32142      &     1.000D+03,  9.453D-02,  9.804D-02,  8.084D-02,  1.208D-01,
32143      &     6.520D-02,  8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,
32144      &     1.093D-01,  1.400D+03,  1.072D-01,  7.450D-02,  6.645D-02,
32145      &     1.136D-01,  6.750D-02,  8.580D-02,  1.110D-01,  1.530D-01,
32146      &     1.010D-01,  1.350D-01,  2.170D+03,  4.004D-02,  3.013D-02,
32147      &     2.664D-02,  5.511D-02,  4.240D-02,  7.660D-02,  1.364D-01,
32148      &     2.300D-01,  1.670D-01,  2.010D-01,  2.900D+03,  1.870D-02,
32149      &     1.804D-02,  1.320D-02,  2.970D-02,  2.860D-02,  5.160D-02,
32150      &     1.020D-01,  2.400D-01,  2.250D-01,  3.370D-01,  4.400D+03,
32151      &     1.196D-03,  8.784D-03,  1.517D-02,  2.874D-02,  2.488D-02,
32152      &     4.464D-02,  8.330D-02,  2.008D-01,  2.360D-01,  3.567D-01/
32153
32154       DATA (DCHN(I),I=1,90) /
32155      &     4.770D-01,  4.750D-01,  4.715D-01,  4.685D-01,  4.650D-01,
32156      &     4.610D-01,  4.570D-01,  4.550D-01,  4.500D-01,  4.450D-01,
32157      &     4.405D-01,  4.350D-01,  4.300D-01,  4.250D-01,  4.200D-01,
32158      &     4.130D-01,  4.060D-01,  4.000D-01,  3.915D-01,  3.840D-01,
32159      &     3.760D-01,  3.675D-01,  3.580D-01,  3.500D-01,  3.400D-01,
32160      &     3.300D-01,  3.200D-01,  3.100D-01,  3.000D-01,  2.900D-01,
32161      &     2.800D-01,  2.700D-01,  2.600D-01,  2.500D-01,  2.400D-01,
32162      &     2.315D-01,  2.240D-01,  2.150D-01,  2.060D-01,  2.000D-01,
32163      &     1.915D-01,  1.850D-01,  1.780D-01,  1.720D-01,  1.660D-01,
32164      &     1.600D-01,  1.550D-01,  1.500D-01,  1.450D-01,  1.400D-01,
32165      &     1.360D-01,  1.320D-01,  1.280D-01,  1.250D-01,  1.210D-01,
32166      &     1.180D-01,  1.150D-01,  1.120D-01,  1.100D-01,  1.070D-01,
32167      &     1.050D-01,  1.030D-01,  1.010D-01,  9.900D-02,  9.700D-02,
32168      &     9.550D-02,  9.480D-02,  9.400D-02,  9.200D-02,  9.150D-02,
32169      &     9.100D-02,  9.000D-02,  8.990D-02,  8.900D-02,  8.850D-02,
32170      &     8.750D-02,  8.700D-02,  8.650D-02,  8.550D-02,  8.500D-02,
32171      &     8.499D-02,  8.450D-02,  8.350D-02,  8.300D-02,  8.250D-02,
32172      &     8.150D-02,  8.100D-02,  8.030D-02,  8.000D-02,  7.990D-02/
32173       DATA (DCHN(I),I=91,143) /
32174      &     7.980D-02,  7.950D-02,  7.900D-02,  7.860D-02,  7.800D-02,
32175      &     7.750D-02,  7.650D-02,  7.620D-02,  7.600D-02,  7.550D-02,
32176      &     7.530D-02,  7.500D-02,  7.499D-02,  7.498D-02,  7.480D-02,
32177      &     7.450D-02,  7.400D-02,  7.350D-02,  7.300D-02,  7.250D-02,
32178      &     7.230D-02,  7.200D-02,  7.100D-02,  7.050D-02,  7.020D-02,
32179      &     7.000D-02,  6.999D-02,  6.995D-02,  6.993D-02,  6.991D-02,
32180      &     6.990D-02,  6.870D-02,  6.850D-02,  6.800D-02,  6.780D-02,
32181      &     6.750D-02,  6.700D-02,  6.650D-02,  6.630D-02,  6.600D-02,
32182      &     6.550D-02,  6.525D-02,  6.510D-02,  6.500D-02,  6.499D-02,
32183      &     6.498D-02,  6.496D-02,  6.494D-02,  6.493D-02,  6.490D-02,
32184      &     6.488D-02,  6.485D-02,  6.480D-02/
32185
32186       DATA DCHNA /
32187      &     6.300D+02,  7.810D-02,  1.421D-01,  1.979D-01,  2.479D-01,
32188      &     3.360D-01,  5.400D-01,  7.236D-01,  1.000D+00,  1.540D+03,
32189      &     2.225D-01,  3.950D-01,  5.279D-01,  6.298D-01,  7.718D-01,
32190      &     9.405D-01,  9.835D-01,  1.000D+00,  2.560D+03,  2.625D-01,
32191      &     4.550D-01,  5.963D-01,  7.020D-01,  8.380D-01,  9.603D-01,
32192      &     9.903D-01,  1.000D+00,  3.520D+03,  4.250D-01,  6.875D-01,
32193      &     8.363D-01,  9.163D-01,  9.828D-01,  1.000D+00,  1.000D+00,
32194      &     1.000D+00/
32195
32196       DATA DCHNB /
32197      &     6.300D+02,  3.800D-02,  7.164D-02,  1.275D-01,  2.171D-01,
32198      &     3.227D-01,  4.091D-01,  5.051D-01,  6.061D-01,  7.074D-01,
32199      &     8.434D-01,  1.000D+00,  2.040D+03,  1.200D-01,  2.115D-01,
32200      &     3.395D-01,  5.295D-01,  7.251D-01,  8.511D-01,  9.487D-01,
32201      &     9.987D-01,  1.000D+00,  1.000D+00,  1.000D+00,  2.200D+03,
32202      &     1.344D-01,  2.324D-01,  3.754D-01,  5.674D-01,  7.624D-01,
32203      &     8.896D-01,  9.808D-01,  1.000D+00,  1.000D+00,  1.000D+00,
32204      &     1.000D+00,  2.850D+03,  2.330D-01,  4.130D-01,  6.610D-01,
32205      &     9.010D-01,  9.970D-01,  1.000D+00,  1.000D+00,  1.000D+00,
32206      &     1.000D+00,  1.000D+00,  1.000D+00,  3.500D+03,  3.300D-01,
32207      &     5.450D-01,  7.950D-01,  1.000D+00,  1.000D+00,  1.000D+00,
32208      &     1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00/
32209
32210       CST = ONE
32211       IF (EKIN.GT.3.5D0) RETURN
32212 C
32213       IF(KPROJ.EQ.8) GOTO 101
32214       IF(KPROJ.EQ.1) GOTO 102
32215 C*                                             INVALID REACTION
32216       WRITE(LOUT,'(A,I5/A)')
32217      &        ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
32218      &        ' COS(THETA) = 1D0 RETURNED'
32219       RETURN
32220 C-------------------------------- NP ELASTIC SCATTERING----------
32221 101   CONTINUE
32222       IF (EKIN.GT.0.740D0)GOTO 1000
32223       IF (EKIN.LT.0.300D0)THEN
32224 C                                 EKIN .LT. 300 MEV
32225          IDAT=1
32226       ELSE
32227 C                                 300 MEV < EKIN < 740 MEV
32228          IDAT=6
32229       END IF
32230 C
32231       ENER=EKIN
32232       IE=INT(ABS(ENER/0.020D0))
32233       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32234 C                                            FORWARD/BACKWARD DECISION
32235       K=IDAT+5*IE
32236       BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32237       IF (DT_RNDM(CST).LT.BWFW)THEN
32238          VALUE2=-1D0
32239          K=K+1
32240       ELSE
32241          VALUE2=1D0
32242          K=K+3
32243       END IF
32244 C
32245       COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32246       RND=DT_RNDM(COEF)
32247 C
32248       IF(RND.LT.COEF)THEN
32249          CST=DT_RNDM(RND)
32250          CST=CST*VALUE2
32251       ELSE
32252          R1=DT_RNDM(CST)
32253          R2=DT_RNDM(R1)
32254          R3=DT_RNDM(R2)
32255          R4=DT_RNDM(R3)
32256 C
32257          IF(VALUE2.GT.0.0)THEN
32258             CST=MAX(R1,R2,R3,R4)
32259             GOTO 1500
32260          ELSE
32261             R5=DT_RNDM(R4)
32262 C
32263             IF (IDAT.EQ.1)THEN
32264                CST=-MAX(R1,R2,R3,R4,R5)
32265             ELSE
32266                R6=DT_RNDM(R5)
32267                R7=DT_RNDM(R6)
32268                CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
32269             END IF
32270 C
32271          END IF
32272 C
32273       END IF
32274 C
32275       GOTO 1500
32276 C
32277 C********                                EKIN  .GT.  0.74 GEV
32278 C
32279 1000  ENER=EKIN - 0.66D0
32280 C     IE=ABS(ENER/0.02)
32281       IE=INT(ENER/0.02D0)
32282       EMEV=EKIN*1D3
32283 C
32284       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32285       K=IE
32286       BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
32287       RND=DT_RNDM(BWFW)
32288 C                                        FORWARD NEUTRON
32289       IF (RND.GE.BWFW)THEN
32290          DO 1200 K=10,36,9
32291            IF (DCHNA(K).GT.EMEV) THEN
32292               UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
32293               UNIV=DT_RNDM(UNIVE)
32294               DO 1100 I=1,8
32295                  II=K+I
32296                  P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
32297 C
32298                  IF (P.GT.UNIV)THEN
32299                     UNIV=DT_RNDM(UNIVE)
32300                     FLTI=DBLE(I)-UNIV
32301                     GOTO(290,290,290,290,330,340,350,360) I
32302                  END IF
32303  1100         CONTINUE
32304            END IF
32305  1200    CONTINUE
32306 C
32307       ELSE
32308 C                                        BACKWARD NEUTRON
32309          DO 1400 K=13,60,12
32310             IF (DCHNB(K).GT.EMEV) THEN
32311                UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
32312                UNIV=DT_RNDM(UNIVE)
32313                DO 1300 I=1,11
32314                  II=K+I
32315                  P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
32316 C
32317                  IF (P.GT.UNIV)THEN
32318                    UNIV=DT_RNDM(P)
32319                    FLTI=DBLE(I)-UNIV
32320                    GOTO(120,120,140,150,160,160,180,190,200,210,220) I
32321                  END IF
32322  1300          CONTINUE
32323             END IF
32324  1400    CONTINUE
32325       END IF
32326 C
32327 120   CST=1.0D-2*FLTI-1.0D0
32328       GOTO 1500
32329 140   CST=2.0D-2*UNIV-0.98D0
32330       GOTO 1500
32331 150   CST=4.0D-2*UNIV-0.96D0
32332       GOTO 1500
32333 160   CST=6.0D-2*FLTI-1.16D0
32334       GOTO 1500
32335 180   CST=8.0D-2*UNIV-0.80D0
32336       GOTO 1500
32337 190   CST=1.0D-1*UNIV-0.72D0
32338       GOTO 1500
32339 200   CST=1.2D-1*UNIV-0.62D0
32340       GOTO 1500
32341 210   CST=2.0D-1*UNIV-0.50D0
32342       GOTO 1500
32343 220   CST=3.0D-1*(UNIV-1.0D0)
32344       GOTO 1500
32345 C
32346 290   CST=1.0D0-2.5d-2*FLTI
32347       GOTO 1500
32348 330   CST=0.85D0+0.5D-1*UNIV
32349       GOTO 1500
32350 340   CST=0.70D0+1.5D-1*UNIV
32351       GOTO 1500
32352 350   CST=0.50D0+2.0D-1*UNIV
32353       GOTO 1500
32354 360   CST=0.50D0*UNIV
32355 C
32356 1500  RETURN
32357 C
32358 C-----------------------------------  PP ELASTIC SCATTERING -------
32359 C
32360  102  CONTINUE
32361       EMEV=EKIN*1D3
32362 C
32363       IF (EKIN.LE.0.500D0) THEN
32364          RND=DT_RNDM(EMEV)
32365          CST=2.0D0*RND-1.0D0
32366          RETURN
32367 C
32368       ELSEIF (EKIN.LT.1.0D0) THEN
32369          DO 2200 K=13,60,12
32370             IF (PDCI(K).GT.EMEV) THEN
32371                UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
32372                UNIV=DT_RNDM(UNIVE)
32373                SUM=0
32374                DO 2100 I=1,11
32375                  II=K+I
32376                  SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
32377 C
32378                  IF (UNIV.LT.SUM)THEN
32379                    UNIV=DT_RNDM(SUM)
32380                    FLTI=DBLE(I)-UNIV
32381                    GOTO(55,55,55,60,60,65,65,65,65,70,70) I
32382                  END IF
32383  2100          CONTINUE
32384             END IF
32385  2200    CONTINUE
32386       ELSE
32387          DO 2400 K=12,55,11
32388             IF (PDCH(K).GT.EMEV) THEN
32389               UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
32390               UNIV=DT_RNDM(UNIVE)
32391               SUM=0.0D0
32392               DO 2300 I=1,10
32393                 II=K+I
32394                 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
32395 C
32396                 IF (UNIV.LT.SUM)THEN
32397                   UNIV=DT_RNDM(SUM)
32398                   FLTI=UNIV+DBLE(I)
32399                   GOTO(50,55,60,60,65,65,65,65,70,70) I
32400                 END IF
32401  2300         CONTINUE
32402             END IF
32403  2400    CONTINUE
32404       END IF
32405 C
32406 50    CST=0.4D0*UNIV
32407       GOTO 2500
32408 55    CST=0.2D0*FLTI
32409       GOTO 2500
32410 60    CST=0.3D0+0.1D0*FLTI
32411       GOTO 2500
32412 65    CST=0.6D0+0.04D0*FLTI
32413       GOTO 2500
32414 70    CST=0.78D0+0.02D0*FLTI
32415 C
32416 2500  CONTINUE
32417       IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
32418 C
32419       RETURN
32420       END
32421
32422 *$ CREATE DT_DHADRI.FOR
32423 *COPY DT_DHADRI
32424 *
32425 *===dhadri=============================================================*
32426 *
32427       SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
32428
32429       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32430       SAVE
32431
32432       PARAMETER ( LINP = 10 ,
32433      &            LOUT = 6 ,
32434      &            LDAT = 9 )
32435
32436 C
32437 C-----------------------------
32438 C*** INPUT VARIABLES LIST:
32439 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
32440 C*** GEV/C LABORATORY MOMENTUM REGION
32441 C*** N    - PROJECTILE HADRON INDEX
32442 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
32443 C*** ELAB - LABORATORY ENERGY OF N (GEV)
32444 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
32445 C*** ITTA - TARGET NUCLEON INDEX
32446 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
32447 C  IR COUNTS THE NUMBER OF PRODUCED PARTICLES
32448 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
32449 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
32450 C*** RESPECT., UNITS (GEV/C AND GEV)
32451 C----------------------------
32452
32453       COMMON /HNGAMR/ REDU,AMO,AMM(15)
32454
32455       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32456
32457       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32458      &                NRK(2,268),NURE(30,2)
32459
32460 * particle properties (BAMJET index convention),
32461 * (dublicate of DTPART for HADRIN)
32462       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32463      &                K1H(110),K2H(110)
32464
32465       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32466
32467       COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
32468      &                ITS(149),IS
32469
32470       COMMON /HNDRUN/ RUNTES,EFTES
32471
32472 * particle properties (BAMJET index convention)
32473       CHARACTER*8  ANAME
32474       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
32475      &                IICH(210),IIBAR(210),K1(210),K2(210)
32476
32477 * final state from HADRIN interaction
32478       PARAMETER (MAXFIN=10)
32479       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
32480      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
32481
32482       DIMENSION ITPRF(110)
32483       DATA NNN/0/
32484       DATA UMODA/0./
32485       DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
32486       LOWP=0
32487       IF (N.LE.0.OR.N.GE.111)N=1
32488       IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
32489         GOTO 280
32490 *       WRITE (6,1000)
32491 *    +  ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
32492 *       STOP
32493 *1000   FORMAT (3(5H ****/),A,2I4,3(5H ****/))
32494 *    +  45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
32495       ENDIF
32496       IATMPT=0
32497       IF (ABS(PLAB-5.0D0).LT.4.99999D0)                        GO TO 20
32498 C     IF(IPRI.GE.1) WRITE (6,1010) PLAB
32499 C     STOP
32500  1010 FORMAT ( '  PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
32501      + ALLOWED REGION, PLAB=',1E15.5)
32502
32503    20 CONTINUE
32504       UMODAT=N*1.11111D0+ITTA*2.19291D0
32505       IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
32506       UMODA=UMODAT
32507    30 IATMPT=0
32508       LOWP=LOWP+1
32509    40 CONTINUE
32510       IMACH=0
32511       REDU=2.0D0
32512       IF (LOWP.GT.20) THEN
32513 C        WRITE(LOUT,*) ' jump 1'
32514          GO TO 280
32515       ENDIF
32516       NNN=N
32517       IF (NNN.EQ.N)                                             GO TO 50
32518       RUNTES=0.0D0
32519       EFTES=0.0D0
32520    50 CONTINUE
32521       IS=1
32522       IRH=0
32523       IST=1
32524       NSTAB=23
32525       IRE=NURE(N,1)
32526       IF(ITTA.GT.1) IRE=NURE(N,2)
32527 C
32528 C-----------------------------
32529 C*** IE,AMT,ECM,SI DETERMINATION
32530 C----------------------------
32531       CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
32532       IANTH=-1
32533 **sr
32534 C     IF (AMH(1).NE.0.93828D0) IANTH=1
32535       IF (AMH(1).NE.0.9383D0) IANTH=1
32536 **
32537       IF (IANTH.GE.0) SI=1.0D0
32538       ECMMH=ECM
32539 C
32540 C-----------------------------
32541 C    ENERGY INDEX
32542 C  IRE CHARACTERIZES THE REACTION
32543 C  IE IS THE ENERGY INDEX
32544 C----------------------------
32545       IF (SI.LT.1.D-6) THEN
32546 C        WRITE(LOUT,*) ' jump 2'
32547          GO TO 280
32548       ENDIF
32549       IF (N.LE.NSTAB)                                           GO TO 60
32550       RUNTES=RUNTES+1.0D0
32551       IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
32552  1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
32553       IF(IBARH(N).EQ.1) N=8
32554       IF(IBARH(N).EQ.-1)  N=9
32555    60 CONTINUE
32556       IMACH=IMACH+1
32557 **sr 19.2.97: loop for direct channel suppression
32558 C     IF (IMACH.GT.10) THEN
32559       IF (IMACH.GT.1000) THEN
32560 **
32561 C        WRITE(LOUT,*) ' jump 3'
32562          GO TO 280
32563       ENDIF
32564       ECM =ECMMH
32565       AMN2=AMN**2
32566       AMT2=AMT**2
32567       ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM    )
32568       IF(ECMN.LE.AMN) ECMN=AMN
32569       PCMN=SQRT(ECMN**2-AMN2)
32570       GAM=(ELAB+AMT)/ECM
32571       BGAM=PLAB/ECM
32572       IF (IANTH.GE.0) ECM=2.1D0
32573 C
32574 C-----------------------------
32575 C*** RANDOM CHOICE OF REACTION CHANNEL
32576 C----------------------------
32577       IST=0
32578       VV=DT_RNDM(AMN2)
32579       VV=VV-1.D-17
32580 C
32581 C-----------------------------
32582 C***  PLACE REDUCED VERSION
32583 C----------------------------
32584       IIEI=IEII(IRE)
32585       IDWK=IEII(IRE+1)-IIEI
32586       IIWK=IRII(IRE)
32587       IIKI=IKII(IRE)
32588 C
32589 C-----------------------------
32590 C***  SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
32591 C----------------------------
32592       HECM=ECM
32593       HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
32594       IF (HUMO.LT.ECM) ECM=HUMO
32595 C
32596 C-----------------------------
32597 C*** INTERPOLATION PREPARATION
32598 C----------------------------
32599       ECMO=UMO(IE)
32600       ECM1=UMO(IE-1)
32601       DECM=ECMO-ECM1
32602       DEC=ECMO-ECM
32603 C
32604 C-----------------------------
32605 C*** RANDOM LOOP
32606 C----------------------------
32607       IK=0
32608       WKK=0.0D0
32609       WICOR=0.0D0
32610    70 IK=IK+1
32611       IWK=IIWK+(IK-1)*IDWK+IE-IIEI
32612       WOK=WK(IWK)
32613       WDK=WOK-WK(IWK-1)
32614 C
32615 C-----------------------------
32616 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
32617 C    GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
32618 C    CONTRIBUTE
32619 C----------------------------
32620       IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
32621       WICO=WOK*1.23459876D0+WDK*1.735218469D0
32622       IF (WICO.EQ.WICOR)                                        GO TO 70
32623       IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
32624       WICOR=WICO
32625 C
32626 C-----------------------------
32627 C*** INTERPOLATION IN CHANNEL WEIGHTS
32628 C----------------------------
32629       EKLIM=-THRESH(IIKI+IK)
32630       IELIM=IDT_IEFUND(EKLIM,IRE)
32631       DELIM=UMO(IELIM)+EKLIM
32632      *+1.D-16
32633       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
32634       IF (DELIM*DELIM-DETE*DETE) 90,90,80
32635    80 DECC=DELIM
32636                                                                GO TO 100
32637    90 DECC=DECM
32638   100 CONTINUE
32639       WKK=WOK-WDK*DEC/(DECC+1.D-9)
32640 C
32641 C-----------------------------
32642 C*** RANDOM CHOICE
32643 C----------------------------
32644 C
32645       IF (VV.GT.WKK)                                            GO TO 70
32646 C
32647 C***IK IS THE REACTION CHANNEL
32648 C----------------------------
32649       INRK=IKII(IRE)+IK
32650       ECM=HECM
32651       I1001 =0
32652 C
32653   110 CONTINUE
32654       IT1=NRK(1,INRK)
32655       AM1=DT_DAMG(IT1)
32656       IT2=NRK(2,INRK)
32657       AM2=DT_DAMG(IT2)
32658       AMS=AM1+AM2
32659       I1001=I1001+1
32660       IF (I1001.GT.50)                                          GO TO 60
32661 C
32662       IF (IT2*AMS.GT.IT2*ECM)                                  GO TO 110
32663       IT11=IT1
32664       IT22=IT2
32665       IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
32666       AM11=AM1
32667       AM22=AM2
32668       IF (IT2.GT.0)                                            GO TO 120
32669 **sr 19.2.97: supress direct channel for pp-collisions
32670       IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
32671          RR = DT_RNDM(AM11)
32672          IF (RR.LE.0.75D0) GOTO 60
32673       ENDIF
32674 **
32675 C
32676 C-----------------------------
32677 C  INCLUSION OF DIRECT RESONANCES
32678 C  RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE  IT1
32679 C------------------------
32680       KZ1=K1H(IT1)
32681       IST=IST+1
32682       IECO=0
32683       ECO=ECM
32684       GAM=(ELAB+AMT)/ECO
32685       BGAM=PLAB/ECO
32686       CXS(1)=CX
32687       CYS(1)=CY
32688       CZS(1)=CZ
32689                                                                GO TO 170
32690   120 CONTINUE
32691       WW=DT_RNDM(ECO)
32692       IF(WW.LT. 0.5D0)                                         GO TO 130
32693       IT1=IT22
32694       IT2=IT11
32695       AM1=AM22
32696       AM2=AM11
32697   130 CONTINUE
32698 C
32699 C-----------------------------
32700 C   THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
32701       IBN=IBARH(N)
32702       IB1=IBARH(IT1)
32703       IT11=IT1
32704       IT22=IT2
32705       AM11=AM1
32706       AM22=AM2
32707       IF(IB1.EQ.IBN)                                           GO TO 140
32708       IT1=IT22
32709       IT2=IT11
32710       AM1=AM22
32711       AM2=AM11
32712   140 CONTINUE
32713 C-----------------------------
32714 C***IT1,IT2 ARE THE CREATED PARTICLES
32715 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
32716 C------------------------
32717       CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
32718      *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
32719       IST=IST+1
32720       ITS(IST)=IT1
32721       AMM(IST)=AM1
32722 C
32723 C-----------------------------
32724 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
32725 C----------------------------
32726       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
32727      &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32728       IST=IST+1
32729       ITS(IST)=IT2
32730       AMM(IST)=AM2
32731       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
32732      *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32733   150 CONTINUE
32734 C
32735 C-----------------------------
32736 C***TEST   STABLE OR UNSTABLE
32737 C----------------------------
32738       IF(ITS(IST).GT.NSTAB)                                    GO TO 160
32739       IRH=IRH+1
32740 C
32741 C-----------------------------
32742 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
32743 C----------------------------
32744 C*    IF (REDU.LT.0.D0) GO TO 1009
32745       ITRH(IRH)=ITS(IST)
32746       PLRH(IRH)=PLS(IST)
32747       CXRH(IRH)=CXS(IST)
32748       CYRH(IRH)=CYS(IST)
32749       CZRH(IRH)=CZS(IST)
32750       ELRH(IRH)=ELS(IST)
32751       IST=IST-1
32752       IF(IST.GE.1)                                             GO TO 150
32753                                                                GO TO 260
32754   160 CONTINUE
32755 C
32756 C  RANDOM CHOICE OF DECAY CHANNELS
32757 C----------------------------
32758 C
32759       IT=ITS(IST)
32760       ECO=AMM(IST)
32761       GAM=ELS(IST)/ECO
32762       BGAM=PLS(IST)/ECO
32763       IECO=0
32764       KZ1=K1H(IT)
32765   170 CONTINUE
32766       IECO=IECO+1
32767       VV=DT_RNDM(GAM)
32768       VV=VV-1.D-17
32769       IIK=KZ1-1
32770   180 IIK=IIK+1
32771       IF (VV.GT.WTI(IIK))                                      GO TO 180
32772 C
32773 C  IIK IS THE DECAY CHANNEL
32774 C----------------------------
32775       IT1=NZKI(IIK,1)
32776       I310=0
32777   190 CONTINUE
32778       I310=I310+1
32779       AM1=DT_DAMG(IT1)
32780       IT2=NZKI(IIK,2)
32781       AM2=DT_DAMG(IT2)
32782       IF (IT2-1.LT.0)                                          GO TO 240
32783       IT3=NZKI(IIK,3)
32784       AM3=DT_DAMG(IT3)
32785       AMS=AM1+AM2+AM3
32786 C
32787 C  IF  IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
32788 C----------------------------
32789       IF (IECO.LE.10)                                          GO TO 200
32790       IATMPT=IATMPT+1
32791       IF(IATMPT.GT.3) THEN
32792 C        WRITE(LOUT,*) ' jump 4'
32793          GO TO 280
32794       ENDIF
32795                                                                 GO TO 40
32796   200 CONTINUE
32797       IF (I310.GT.50)                                          GO TO 170
32798       IF (AMS.GT.ECO)                                          GO TO 190
32799 C
32800 C  FOR THE DECAY CHANNEL
32801 C  IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM  IT
32802 C----------------------------
32803       IF (REDU.LT.0.D0)                                        GO TO 30
32804       ITWTHC=0
32805       REDU=2.0D0
32806       IF(IT3.EQ.0)                                             GO TO 220
32807   210 CONTINUE
32808       ITWTH=1
32809       CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
32810      *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
32811                                                                GO TO 230
32812   220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
32813      &COD2,COF2,SIF2,AM1,AM2)
32814       ITWTH=-1
32815       IT3=0
32816   230 CONTINUE
32817       ITWTHC=ITWTHC+1
32818       IF (REDU.GT.0.D0)                                        GO TO 240
32819       REDU=2.0D0
32820       IF (ITWTHC.GT.100)                                        GO TO 30
32821       IF (ITWTH) 220,220,210
32822   240 CONTINUE
32823       ITS(IST  )=IT1
32824       IF (IT2-1.LT.0)                                          GO TO 250
32825       ITS(IST+1)  =IT2
32826       ITS(IST+2)=IT3
32827       RX=CXS(IST)
32828       RY=CYS(IST)
32829       RZ=CZS(IST)
32830       AMM(IST)=AM1
32831       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
32832      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32833       IST=IST+1
32834       AMM(IST)=AM2
32835       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
32836      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32837       IF (IT3.LE.0)                                            GO TO 250
32838       IST=IST+1
32839       AMM(IST)=AM3
32840       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
32841      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32842   250 CONTINUE
32843                                                                GO TO 150
32844   260 CONTINUE
32845   270 CONTINUE
32846       RETURN
32847   280 CONTINUE
32848 C
32849 C----------------------------
32850 C
32851 C   ZERO CROSS SECTION CASE
32852 C----------------------------
32853 C
32854       IRH=1
32855       ITRH(1)=N
32856       CXRH(1)=CX
32857       CYRH(1)=CY
32858       CZRH(1)=CZ
32859       ELRH(1)=ELAB
32860       PLRH(1)=PLAB
32861       RETURN
32862       END
32863
32864 *$ CREATE DT_RUNTT.FOR
32865 *COPY DT_RUNTT
32866 *
32867 *===runtt==============================================================*
32868 *
32869       BLOCK DATA DT_RUNTT
32870
32871       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32872       SAVE
32873
32874       COMMON /HNDRUN/ RUNTES,EFTES
32875
32876       DATA RUNTES,EFTES /100.D0,100.D0/
32877
32878       END
32879
32880 *$ CREATE DT_NONAME.FOR
32881 *COPY DT_NONAME
32882 *
32883 *===noname=============================================================*
32884 *
32885       BLOCK DATA DT_NONAME
32886
32887       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32888       SAVE
32889
32890 * slope parameters for HADRIN interactions
32891       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
32892
32893       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32894
32895 C     DATAS     DATAS    DATAS      DATAS     DATAS
32896 C******          *********
32897       DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
32898      &           207, 224, 241, 252, 268 /
32899       DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
32900      &           220, 241, 262, 279, 296 /
32901       DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
32902      &           3364, 3507, 4011, 4368, 4725, 4912, 5184/
32903
32904 C
32905 C     MASSES FOR THE SLOPE B(M) IN GEV
32906 C     SLOPE B(M) FOR AN MESONIC SYSTEM
32907 C     SLOPE B(M) FOR A BARYONIC SYSTEM
32908
32909 *
32910       DATA SM,BBM,BBB/  0.8D0, 0.85D0,  0.9D0, 0.95D0, 1.D0,
32911      &     1.05D0,  1.1D0, 1.15D0,  1.2D0, 1.25D0,
32912      &      1.3D0,  1.35D0, 1.4D0,  1.45D0,  1.5D0,
32913      &     1.55D0,  1.6D0,  1.65D0, 1.7D0,   1.75D0,
32914      &      1.8D0,  1.85D0, 1.9D0,  1.95D0,  2.D0,
32915      &     15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
32916      &    12.35D0, 11.7D0, 10.85D0, 10.D0,  9.15D0,
32917      &      8.3D0,  7.8D0,  7.3D0,  7.25D0,  7.2D0,
32918      &     6.95D0,  6.7D0,  6.6D0,  6.5D0,   6.3D0,
32919      &      6.1D0,  5.85D0, 5.6D0,  5.35D0,  5.1D0,
32920      &      15.D0,   15.D0, 15.D0,  15.D0,   15.D0, 15.D0, 15.D0,
32921      &     14.2D0,  13.4D0, 12.6D0,
32922      &     11.8D0, 11.2D0, 10.6D0,  9.8D0,    9.D0,
32923      &     8.25D0,  7.5D0, 6.25D0,  5.D0,    4.5D0, 5*4.D0 /
32924 *
32925       END
32926
32927 *$ CREATE DT_DAMG.FOR
32928 *COPY DT_DAMG
32929 *
32930 *===damg===============================================================*
32931 *
32932       DOUBLE PRECISION FUNCTION DT_DAMG(IT)
32933
32934       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32935       SAVE
32936
32937 * particle properties (BAMJET index convention),
32938 * (dublicate of DTPART for HADRIN)
32939       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32940      &                K1H(110),K2H(110)
32941
32942       DIMENSION GASUNI(14)
32943       DATA GASUNI/
32944      *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
32945      *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
32946       DATA GAUNO/2.352D0/
32947       DATA GAUNON/2.4D0/
32948       DATA IO/14/
32949       DATA NSTAB/23/
32950
32951       I=1
32952       IF (IT.LE.0)                                              GO TO 30
32953       IF (IT.LE.NSTAB)                                          GO TO 20
32954       DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
32955       VV=DT_RNDM(DGAUNI)
32956       VV=VV*2.0D0-1.0D0+1.D-16
32957    10 CONTINUE
32958       VO=GASUNI(I)
32959       I=I+1
32960       V1=GASUNI(I)
32961       IF (VV.GT.V1)                                             GO TO 10
32962       UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
32963      &      (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
32964       DAM=GAH(IT)*UNIGA/GAUNO
32965       AAM=AMH(IT)+DAM
32966       DT_DAMG=AAM
32967       RETURN
32968    20 CONTINUE
32969       DT_DAMG=AMH(IT)
32970       RETURN
32971    30 CONTINUE
32972       DT_DAMG=0.0D0
32973       RETURN
32974       END
32975
32976 *$ CREATE DT_DCALUM.FOR
32977 *COPY DT_DCALUM
32978 *
32979 *===dcalum=============================================================*
32980 *
32981       SUBROUTINE DT_DCALUM(N,ITTA)
32982
32983       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32984       SAVE
32985
32986 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
32987
32988 * particle properties (BAMJET index convention),
32989 * (dublicate of DTPART for HADRIN)
32990       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32991      &                K1H(110),K2H(110)
32992
32993       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32994
32995       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32996
32997       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32998      &                NRK(2,268),NURE(30,2)
32999
33000       IRE=NURE(N,ITTA/8+1)
33001       IEO=IEII(IRE)+1
33002       IEE=IEII(IRE +1)
33003       AM1=AMH(N   )
33004       AM12=AM1**2
33005       AM2=AMH(ITTA)
33006       AM22=AM2**2
33007       DO 10 IE=IEO,IEE
33008         PLAB2=PLABF(IE)**2
33009         ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
33010         UMO(IE)=ELAB
33011    10 CONTINUE
33012       IKO=IKII(IRE)+1
33013       IKE=IKII(IRE +1)
33014       UMOO=UMO(IEO)
33015       DO 30 IK=IKO,IKE
33016         IF(NRK(2,IK).GT.0)                                      GO TO 30
33017         IKI=NRK(1,IK)
33018         AMSS=5.0D0
33019         K11=K1H(IKI)
33020         K22=K2H(IKI)
33021         DO 20 IK1=K11,K22
33022           IN=NZKI(IK1,1)
33023           AMS=AMH(IN)
33024           IN=NZKI(IK1,2)
33025           IF(IN.GT.0)AMS=AMS+AMH(IN)
33026           IN=NZKI(IK1,3)
33027           IF(IN.GT.0) AMS=AMS+AMH(IN)
33028           IF (AMS.LT.AMSS) AMSS=AMS
33029    20   CONTINUE
33030         IF(UMOO.LT.AMSS) UMOO=AMSS
33031         THRESH(IK)=UMOO
33032    30 CONTINUE
33033       RETURN
33034       END
33035
33036 *$ CREATE DT_DCHANH.FOR
33037 *COPY DT_DCHANH
33038 *
33039 *===dchanh=============================================================*
33040 *
33041       SUBROUTINE DT_DCHANH
33042
33043       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33044       SAVE
33045
33046       PARAMETER ( LINP = 10 ,
33047      &            LOUT = 6 ,
33048      &            LDAT = 9 )
33049
33050 * particle properties (BAMJET index convention),
33051 * (dublicate of DTPART for HADRIN)
33052       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33053      &                K1H(110),K2H(110)
33054
33055       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33056
33057       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33058
33059       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33060      &                NRK(2,268),NURE(30,2)
33061
33062       DIMENSION HWT(460),HWK(40),SI(5184)
33063       EQUIVALENCE (WK(1),SI(1))
33064 C--------------------
33065 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
33066 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
33067 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
33068 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
33069 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
33070 C--------------------------
33071       IREG=16
33072       DO 90 IRE=1,IREG
33073         IWKO=IRII(IRE)
33074         IEE=IEII(IRE+1)-IEII(IRE)
33075         IKE=IKII(IRE+1)-IKII(IRE)
33076         IEO=IEII(IRE)+1
33077         IIKA=IKII(IRE)
33078 *   modifications to suppress elestic scattering  24/07/91
33079         DO 80 IE=1,IEE
33080           SIS=1.D-14
33081           SINORC=0.0D0
33082           DO 10 IK=1,IKE
33083             IWK=IWKO+IEE*(IK-1)+IE
33084             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33085             SIS=SIS+SI(IWK)*SINORC
33086    10     CONTINUE
33087           SIIN(IEO+IE-1)=SIS
33088           SIO=0.D0
33089           IF (SIS.GE.1.D-12)                                    GO TO 20
33090           SIS=1.D0
33091           SIO=1.D0
33092    20     CONTINUE
33093           SINORC=0.0D0
33094           DO 30 IK=1,IKE
33095             IWK=IWKO+IEE*(IK-1)+IE
33096             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33097             SIO=SIO+SI(IWK)*SINORC/SIS
33098             HWK(IK)=SIO
33099    30     CONTINUE
33100           DO 40 IK=1,IKE
33101             IWK=IWKO+IEE*(IK-1)+IE
33102    40     WK(IWK)=HWK(IK)
33103           IIKI=IKII(IRE)
33104           DO 70 IK=1,IKE
33105             AM111=0.D0
33106             INRK1=NRK(1,IIKI+IK)
33107             IF (INRK1.GT.0) AM111=AMH(INRK1)
33108             AM222=0.D0
33109             INRK2=NRK(2,IIKI+IK)
33110             IF (INRK2.GT.0) AM222=AMH(INRK2)
33111             THRESH(IIKI+IK)=AM111 +AM222
33112             IF (INRK2-1.GE.0)                                   GO TO 60
33113             INRKK=K1H(INRK1)
33114             AMSS=5.D0
33115             INRKO=K2H(INRK1)
33116             DO 50 INRK1=INRKK,INRKO
33117               INZK1=NZKI(INRK1,1)
33118               INZK2=NZKI(INRK1,2)
33119               INZK3=NZKI(INRK1,3)
33120               IF (INZK1.LE.0.OR.INZK1.GT.110)                   GO TO 50
33121               IF (INZK2.LE.0.OR.INZK2.GT.110)                   GO TO 50
33122               IF (INZK3.LE.0.OR.INZK3.GT.110)                   GO TO 50
33123 C     WRITE (6,310)INRK1,INZK1,INZK2,INZK3
33124  1000 FORMAT (4I10)
33125               AMS=AMH(INZK1)+AMH(INZK2)
33126               IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
33127               IF (AMSS.GT.AMS) AMSS=AMS
33128    50       CONTINUE
33129             AMS=AMSS
33130             IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
33131             THRESH(IIKI+IK)=AMS
33132    60       CONTINUE
33133    70     CONTINUE
33134    80   CONTINUE
33135    90 CONTINUE
33136       DO 100 J=1,460
33137   100 HWT(J)=0.D0
33138       DO 120 I=1,110
33139         IK1=K1H(I)
33140         IK2=K2H(I)
33141         HV=0.D0
33142         IF (IK2.GT.460)IK2=460
33143         IF (IK1.LE.0)IK1=1
33144         DO 110 J=IK1,IK2
33145           HV=HV+WTI(J)
33146           HWT(J)=HV
33147           JI=J
33148   110   CONTINUE
33149         IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
33150  1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
33151   120 CONTINUE
33152       DO 130 J=1,460
33153   130 WTI(J)=HWT(J)
33154       RETURN
33155       END
33156
33157 *$ CREATE DT_DHADDE.FOR
33158 *COPY DT_DHADDE
33159 *
33160 *===dhadde=============================================================*
33161 *
33162       SUBROUTINE DT_DHADDE
33163
33164       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33165       SAVE
33166
33167 * particle properties (BAMJET index convention)
33168       CHARACTER*8  ANAME
33169       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33170      &                IICH(210),IIBAR(210),K1(210),K2(210)
33171
33172 * HADRIN: decay channel information
33173       PARAMETER (IDMAX9=602)
33174       CHARACTER*8 ZKNAME
33175       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
33176
33177 * particle properties (BAMJET index convention),
33178 * (dublicate of DTPART for HADRIN)
33179       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33180      &                K1H(110),K2H(110)
33181
33182       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33183
33184 * decay channel information for HADRIN
33185       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33186      &                K1Z(16),K2Z(16),WTZ(153),II22,
33187      &                NZK1(153),NZK2(153),NZK3(153)
33188
33189       DATA IRETUR/0/
33190
33191       IRETUR=IRETUR+1
33192       AMH(31)=0.48D0
33193       IF (IRETUR.GT.1) RETURN
33194       DO 10 I=1,94
33195         AMH(I)   = AAM(I)
33196         GAH(I)   = GA(I)
33197         TAUH(I)  = TAU(I)
33198         ICHH(I)  = IICH(I)
33199         IBARH(I) = IIBAR(I)
33200         K1H(I)   = K1(I)
33201         K2H(I)   = K2(I)
33202    10 CONTINUE
33203 **sr
33204 C     AMH(1)=0.93828D0
33205       AMH(1)=0.9383D0
33206 **
33207       AMH(2)=AMH(1)
33208       DO 20 I=26,30
33209         K1H(I)=452
33210         K2H(I)=452
33211    20 CONTINUE
33212       DO 30 I=1,307
33213         WTI(I)    = WT(I)
33214         NZKI(I,1) = NZK(I,1)
33215         NZKI(I,2) = NZK(I,2)
33216         NZKI(I,3) = NZK(I,3)
33217    30 CONTINUE
33218       DO 40 I=1,16
33219         L=I+94
33220         AMH(L)=AMZ(I)
33221         GAH( L)=GAZ(I)
33222         TAUH( L)=TAUZ(I)
33223         ICHH( L)=ICHZ(I)
33224         IBARH( L)=IBARZ(I)
33225         K1H( L)=K1Z(I)
33226         K2H( L)=K2Z(I)
33227    40 CONTINUE
33228       DO 50 I=1,153
33229         L=I+307
33230         WTI(L)    = WTZ(I)
33231         NZKI(L,3) = NZK3(I)
33232         NZKI(L,2) = NZK2(I)
33233         NZKI(L,1) = NZK1(I)
33234    50 CONTINUE
33235       RETURN
33236       END
33237
33238 *$ CREATE IDT_IEFUND.FOR
33239 *COPY IDT_IEFUND
33240 *
33241 *===iefund=============================================================*
33242 *
33243       INTEGER FUNCTION IDT_IEFUND(PL,IRE)
33244
33245       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33246       SAVE
33247
33248 C*****IEFUN CALCULATES A MOMENTUM INDEX
33249
33250       PARAMETER ( LINP = 10 ,
33251      &            LOUT = 6 ,
33252      &            LDAT = 9 )
33253
33254       COMMON /HNDRUN/ RUNTES,EFTES
33255
33256       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33257
33258       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33259      &                NRK(2,268),NURE(30,2)
33260
33261       IPLA=IEII(IRE)+1
33262      *+1
33263       IPLE=IEII(IRE+1)
33264       IF (PL.LT.0.)                                             GO TO 30
33265       DO 10 I=IPLA,IPLE
33266         J=I-IPLA+1
33267         IF (PL.LE.PLABF(I))                                     GO TO 60
33268    10 CONTINUE
33269       I=IPLE
33270       IF ( EFTES.GT.40.D0)                                      GO TO 20
33271       EFTES=EFTES+1.0D0
33272       WRITE(LOUT,1000)PL,J
33273    20 CONTINUE
33274                                                                 GO TO 70
33275    30 CONTINUE
33276       DO 40 I=IPLA,IPLE
33277         J=I-IPLA+1
33278         IF (-PL.LE.UMO(I))                                      GO TO 60
33279    40 CONTINUE
33280       I=IPLE
33281       IF ( EFTES.GT.40.D0)                                      GO TO 50
33282       EFTES=EFTES+1.0D0
33283       WRITE(LOUT,1000)PL,I
33284    50 CONTINUE
33285    60 CONTINUE
33286    70 CONTINUE
33287       IDT_IEFUND=I
33288       RETURN
33289  1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
33290      +7H IEFUN=,I5)
33291       END
33292
33293 *$ CREATE DT_DSIGIN.FOR
33294 *COPY DT_DSIGIN
33295 *
33296 *===dsigin=============================================================*
33297 *
33298       SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
33299
33300       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33301       SAVE
33302
33303 * particle properties (BAMJET index convention),
33304 * (dublicate of DTPART for HADRIN)
33305       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33306      &                K1H(110),K2H(110)
33307
33308       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33309
33310       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33311      &                NRK(2,268),NURE(30,2)
33312
33313       IE=IDT_IEFUND(PLAB,IRE)
33314       IF (IE.LE.IEII(IRE)) IE=IE+1
33315       AMT=AMH(ITAR)
33316       AMN=AMH(N)
33317       AMN2=AMN*AMN
33318       AMT2=AMT*AMT
33319       ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
33320 C*** INTERPOLATION PREPARATION
33321       ECMO=UMO(IE)
33322       ECM1=UMO(IE-1)
33323       DECM=ECMO-ECM1
33324       DEC=ECMO-ECM
33325       IIKI=IKII(IRE)+1
33326       EKLIM=-THRESH(IIKI)
33327       WOK=SIIN(IE)
33328       WDK=WOK-SIIN(IE-1)
33329       IF (ECM.GT.ECMO) WDK=0.0D0
33330 C*** INTERPOLATION IN CHANNEL WEIGHTS
33331       IELIM=IDT_IEFUND(EKLIM,IRE)
33332       DELIM=UMO(IELIM)+EKLIM
33333      *+1.D-16
33334       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
33335       IF (DELIM*DELIM-DETE*DETE) 20,20,10
33336    10 DECC=DELIM
33337                                                                 GO TO 30
33338    20 DECC=DECM
33339    30 CONTINUE
33340       WKK=WOK-WDK*DEC/(DECC+1.D-9)
33341       IF (WKK.LT.0.0D0) WKK=0.0D0
33342       SI=WKK+1.D-12
33343       IF (-EKLIM.GT.ECM) SI=1.D-14
33344       RETURN
33345       END
33346
33347 *$ CREATE DT_DTCHOI.FOR
33348 *COPY DT_DTCHOI
33349 *
33350 *===dtchoi=============================================================*
33351 *
33352       SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
33353
33354       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33355       SAVE
33356
33357 C     ****************************
33358 C     TCHOIC CALCULATES A RANDOM VALUE
33359 C     FOR THE FOUR-MOMENTUM-TRANSFER T
33360 C     ****************************
33361
33362 * particle properties (BAMJET index convention),
33363 * (dublicate of DTPART for HADRIN)
33364       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33365      &                K1H(110),K2H(110)
33366
33367 * slope parameters for HADRIN interactions
33368       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
33369
33370       AMA=AM1
33371       AMB=AM2
33372       IF (I.GT.30.AND.II.GT.30)                                 GO TO 20
33373       III=II
33374       AM3=AM2
33375       IF (I.LE.30)                                              GO TO 10
33376       III=I
33377       AM3=AM1
33378    10 CONTINUE
33379                                                                 GO TO 30
33380    20 CONTINUE
33381       III=II
33382       AM3=AM2
33383       IF (AMA.LE.AMB)                                           GO TO 30
33384       III=I
33385       AM3=AM1
33386    30 CONTINUE
33387       IB=IBARH(III)
33388       AMA=AM3
33389       K=INT((AMA-0.75D0)/0.05D0)
33390       IF (K-2.LT.0) K=1
33391       IF (K-26.GE.0) K=25
33392       IF (IB)50,40,50
33393    40 BM=BBM(K)
33394                                                                 GO TO 60
33395    50 BM=BBB(K)
33396    60 CONTINUE
33397 C     NORMALIZATION
33398       TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1  **2
33399       TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1  **2
33400       VB=DT_RNDM(TMIN)
33401 **sr test
33402 C     IF (VB.LT.0.2D0) BM=BM*0.1
33403 C    **0.5
33404       BM = BM*5.05D0
33405 **
33406       TMI=BM*TMIN
33407       TMA=BM*TMAX
33408       ETMA=0.D0
33409       IF (ABS(TMA).GT.120.D0)                                   GO TO 70
33410       ETMA=EXP(TMA)
33411    70 CONTINUE
33412       AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
33413 C*** RANDOM CHOICE OF THE T - VALUE
33414       R=DT_RNDM(TMI)
33415       T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
33416       RETURN
33417       END
33418
33419 *$ CREATE DT_DTWOPA.FOR
33420 *COPY DT_DTWOPA
33421 *
33422 *===dtwopa=============================================================*
33423 *
33424       SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
33425      &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
33426
33427       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33428       SAVE
33429
33430 C     ******************************************************
33431 C     QUASI TWO PARTICLE PRODUCTION
33432 C     TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
33433 C     FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
33434 C     IN THE CM - SYSTEM
33435 C     COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
33436 C     SPHERICAL COORDINATES
33437 C     ******************************************************
33438
33439 * particle properties (BAMJET index convention),
33440 * (dublicate of DTPART for HADRIN)
33441       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33442      &                K1H(110),K2H(110)
33443
33444       AMA=AM1
33445       AMB=AM2
33446       AMA2=AMA*AMA
33447       E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
33448       E2=UMOO - E1
33449       IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
33450       AMTE=(E1-AMA)*(E1+AMA)
33451       AMTE=AMTE+1.D-18
33452       P1=SQRT(AMTE)
33453       P2=P1
33454 C     / P2 / = / P1 /  BUT OPPOSITE DIRECTIONS
33455 C     DETERMINATION  OF  THE ANGLES
33456 C     COS(THETA1)=COD1      COS(THETA2)=COD2
33457 C     SIN(PHI1)=SIF1        SIN(PHI2)=SIF2
33458 C     COS(PHI1)=COF1        COS(PHI2)=COF2
33459 C     PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
33460       CALL DT_DSFECF(COF1,SIF1)
33461       COF2=-COF1
33462       SIF2=-SIF1
33463 C     CALCULATION OF THETA1
33464       CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
33465       COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
33466       IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
33467       COD2=-COD1
33468       RETURN
33469       END
33470
33471 *$ CREATE DT_ZK.FOR
33472 *COPY DT_ZK
33473 *
33474 *===zk=================================================================*
33475 *
33476       BLOCK DATA DT_ZK
33477
33478       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33479       SAVE
33480
33481 * decay channel information for HADRIN
33482       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33483      &                K1Z(16),K2Z(16),WTZ(153),II22,
33484      &                NZK1(153),NZK2(153),NZK3(153)
33485
33486 * decay channel information for HADRIN
33487       CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
33488       COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
33489
33490 *     Particle masses in GeV                                           *
33491       DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
33492      &          2*1.7D0, 3*0.D0/
33493 *     Resonance width Gamma in GeV                                     *
33494       DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
33495 *     Mean life time in seconds                                        *
33496       DATA TAUZ / 16*0.D0 /
33497 *     Charge of particles and resonances                               *
33498       DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
33499 *     Baryonic charge                                                  *
33500       DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
33501 *     First number of decay channels used for resonances               *
33502 *     and decaying particles                                           *
33503       DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
33504      &          3*460/
33505 *     Last number of decay channels used for resonances                *
33506 *     and decaying particles                                           *
33507       DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
33508      &          3*460/
33509 *     Weight of decay channel                                          *
33510       DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
33511      & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
33512      & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
33513      & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
33514      & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
33515      & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
33516      & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
33517      & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
33518      & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
33519      & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
33520      & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
33521      & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
33522      & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
33523      & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
33524      & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
33525      & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
33526      & .05D0, .65D0, 9*1.D0 /
33527 *     Particle numbers in decay channel                                *
33528       DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
33529      & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
33530      & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
33531      & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
33532      & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
33533      & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
33534      & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
33535      & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
33536       DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
33537      & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
33538      & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
33539      & 4*33, 32, 3*35,  2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
33540      & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
33541      & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
33542      & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
33543      & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
33544      & 1, 8, 1, 8, 1, 9*0 /
33545       DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
33546      & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
33547      & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
33548      & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
33549      & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
33550      & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
33551 *     Particle  names                                                  *
33552       DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS  ',' PAP  ',' PAN  ',
33553      & 'APN', 'DEO   ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
33554      & 3*'BLANK' /
33555 *     Name of decay channel                                            *
33556       DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
33557      & 'ANNPI0','APPPI0','ANPPI-'/
33558       DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K-  ','K0AK0 ',
33559      & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET  ','&0R0  ','P-R+  ',
33560      & 'P+R-  ','POOM  ',' ETET ','ETSP0 ','R0ET  ',' R0R0 ','R+R-  ',
33561      & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
33562      & 'P+R-R0','R0OM  ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
33563      & 'P+R-OM','OMOM  ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
33564      & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
33565      & 'OMOMOM',
33566      & ' P+PO ','P+POPO','P+P+P-','P+ET  ','P0R+  ','P+R0  ','ETSP+ ',
33567      & 'R+ET  ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
33568      & 'P+R-R+','R+OM  ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
33569      & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
33570      & 'P-PO  ','P-POPO','P-P-P+','P-ET  ','POR-  ','P-R0  ','ETSP- ',
33571      & 'R-ET  ','R-R0  ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
33572       DATA ZKNAM6/'P+R-R-','R-OM  ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
33573      & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
33574      & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO  ','LPI+  ',
33575      & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
33576      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
33577      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
33578      & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
33579      & 9*'BLANK'/
33580 *=                                               end*block.zk      *
33581       END
33582
33583 *$ CREATE DT_BLKD43.FOR
33584 *COPY DT_BLKD43
33585 *
33586 *===blkd43=============================================================*
33587 *
33588       BLOCK DATA DT_BLKD43
33589
33590       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33591       SAVE
33592
33593 *
33594 *=== reac =============================================================*
33595 *
33596 *----------------------------------------------------------------------*
33597 *                                                                      *
33598 *     Created on 10 december 1991  by    Alfredo Ferrari & Paola Sala  *
33599 *                                                   Infn - Milan       *
33600 *                                                                      *
33601 *     Last change on 10-dec-91     by    Alfredo Ferrari               *
33602 *                                                                      *
33603 *     This is the original common reac of Hadrin                       *
33604 *                                                                      *
33605 *----------------------------------------------------------------------*
33606 *
33607
33608       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33609      &                NRK(2,268),NURE(30,2)
33610
33611       DIMENSION
33612      & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
33613      & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
33614      & SPIKP1(315), SPIKPU(278), SPIKPV(372),
33615      & SPIKPW(278), SPIKPX(372), SPIKP4(315),
33616      & SPIKP5(187), SPIKP6(289),
33617      & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
33618      & SPIKP9(143), SPIKP0(169), SPKPV(143),
33619      & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
33620      & SANPEL(84) , SPIKPF(273),
33621      & SPKP15(187), SPKP16(272),
33622      & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
33623      & NURELN(60)
33624 *
33625        DIMENSION NRKLIN(532)
33626        EQUIVALENCE (NRK(1,1), NRKLIN(1))
33627        EQUIVALENCE (   UMO(  1),  UMOPI(1)), (   UMO( 93),  UMOKC(1))
33628        EQUIVALENCE (   UMO(161),   UMOP(1)), (   UMO(200),   UMON(1))
33629        EQUIVALENCE (   UMO(263),  UMOK0(1))
33630        EQUIVALENCE ( PLABF(  1),  PLAPI(1)), ( PLABF( 93),  PLAKC(1))
33631        EQUIVALENCE ( PLABF(161),   PLAP(1)), ( PLABF(200),   PLAN(1))
33632        EQUIVALENCE ( PLABF(263),  PLAK0(1))
33633        EQUIVALENCE (   WK(   1), SPIKP1(1)), (   WK( 316), SPIKPU(1))
33634        EQUIVALENCE (   WK( 594), SPIKPV(1)), (   WK( 966), SPIKPW(1))
33635        EQUIVALENCE (   WK(1244), SPIKPX(1)), (   WK(1616), SPIKP4(1))
33636        EQUIVALENCE (   WK(1931), SPIKP5(1)), (   WK(2118), SPIKP6(1))
33637        EQUIVALENCE (   WK(2407), SKMPEL(1)), (   WK(2509), SPIKP7(1))
33638        EQUIVALENCE (   WK(2798), SKMNEL(1)), (   WK(2866), SPIKP8(1))
33639        EQUIVALENCE (   WK(3053), SPIKP9(1)), (   WK(3196), SPIKP0(1))
33640        EQUIVALENCE (   WK(3365),  SPKPV(1)), (   WK(3508), SAPPEL(1))
33641        EQUIVALENCE (   WK(3613), SPIKPE(1)), (   WK(4012), SAPNEL(1))
33642        EQUIVALENCE (   WK(4096), SPIKPZ(1)), (   WK(4369), SANPEL(1))
33643        EQUIVALENCE (   WK(4453), SPIKPF(1)), (   WK(4726), SPKP15(1))
33644        EQUIVALENCE (   WK(4913), SPKP16(1))
33645        EQUIVALENCE (NRK(1,1), NRKLIN(1))
33646        EQUIVALENCE (NRKLIN(   1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
33647        EQUIVALENCE (NRKLIN( 297),  NRKP(1)), (NRKLIN( 367),  NRKN(1))
33648        EQUIVALENCE (NRKLIN( 483), NRKK0(1))
33649        EQUIVALENCE (NURE(1,1), NURELN(1))
33650 *
33651 **** pi- p data                                                        *
33652 **** pi+ n data                                                        *
33653       DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
33654      & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
33655      & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
33656      & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
33657      & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
33658      & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
33659      & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
33660      & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
33661      & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
33662      & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
33663       DATA PLAKC /
33664      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33665      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33666      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33667      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33668      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33669      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33670      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33671      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33672      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33673      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33674      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33675      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33676       DATA PLAK0 /
33677      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33678      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33679      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33680      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33681      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33682      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33683 *                 pp   pn   np   nn                                    *
33684       DATA PLAP /
33685      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33686      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33687      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33688      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33689      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33690      & 3.43D0, 3.75D0, 4.07D0, 4.43D0 /
33691 *    app   apn   anp   ann                                             *
33692       DATA PLAN /
33693      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
33694      & .74D0,  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      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
33697      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33698      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33699      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
33700      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33701      & 3.43D0, 3.75D0, 4.07D0, 4.43D0  /
33702       DATA SIIN / 296*0.D0 /
33703       DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33704      & 1.557D0,1.615D0,1.6435D0,
33705      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33706      & 2.286D0,2.366D0,2.482D0,2.56D0,
33707      & 2.735D0,2.90D0,
33708      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33709      & 1.496D0,1.527D0,1.557D0,
33710      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33711      & 2.071D0,2.159D0,2.286D0,2.366D0,
33712      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
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.233D0,1.302D0,1.369D0,1.496D0,
33719      & 1.557D0,1.615D0,1.6435D0,
33720      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33721      & 2.286D0,2.366D0,2.482D0,2.56D0,
33722      &  2.735D0, 2.90D0/
33723       DATA UMOKC/ 1.44D0,
33724      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33725      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33726      & 3.1D0,1.44D0,
33727      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33728      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33729      & 3.1D0,1.44D0,
33730      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33731      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33732      & 3.1D0,1.44D0,
33733      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33734      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33735      &  3.1D0/
33736       DATA UMOK0/ 1.44D0,
33737      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33738      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33739      & 3.1D0,1.44D0,
33740      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33741      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33742      &  3.1D0/
33743 *                 pp   pn   np   nn                                    *
33744       DATA UMOP/
33745      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33746      & 3.D0,3.1D0,3.2D0,
33747      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33748      & 3.D0,3.1D0,3.2D0,
33749      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33750      & 3.D0,3.1D0,3.2D0/
33751 *    app   apn   anp   ann                                             *
33752       DATA UMON /
33753      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33754      & 2.D0,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      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33757      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33758      & 3.D0,3.1D0,3.2D0,
33759      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33760      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33761      &  3.D0,3.1D0,3.2D0/
33762 **** reaction channel state particles                                  *
33763       DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
33764      & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
33765      & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
33766      & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
33767      & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
33768      & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
33769      & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
33770      & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
33771      & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
33772      & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
33773       DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
33774      & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
33775      & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
33776      & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
33777      & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
33778      & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
33779      & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
33780      & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
33781 *                                                                      *
33782 *   k0 p   k0 n   ak0 p   ak/ n                                        *
33783 *                                                                      *
33784       DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
33785      & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13,   22, 13, 21, 23,
33786      & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
33787      & 53, 47, 1, 103, 0, 93, 0/
33788 *   pp  pn   np   nn                                                   *
33789       DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
33790      & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
33791      & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
33792      & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
33793 *     app   apn   anp   ann                                            *
33794       DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
33795      & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
33796      & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
33797      & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
33798      & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
33799      & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
33800      & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
33801 **** channel cross section                                             *
33802       DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
33803      & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
33804      & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
33805      & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
33806      & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
33807      &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
33808      & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
33809      & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
33810      &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
33811      & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
33812      & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
33813      & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
33814      & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
33815      & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
33816      & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
33817      & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
33818      & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
33819      & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
33820      & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
33821      & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
33822 **** pi+ n data                                                        *
33823       DATA SPIKPU/   0.D0, 25.D0, 13.D0,  11.D0, 10.5D0, 14.D0,  20.D0,
33824      & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33825      & 10.D0, 10.D0, 9.5D0,  9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33826      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0,   5.5D0,  4.8D0,
33827      & 4.2D0, 7.5D0, 3.4D0,  2.5D0, 2.5D0, 2.1D0, 1.4D0,   1.D0,   .8D0,
33828      &  .6D0, .46D0,  .3D0, .2D0, .15D0, .13D0, 11*0.D0,  .95D0,  .65D0,
33829      & .48D0, .35D0,  .2D0, .18D0, .17D0, .16D0,  .15D0,   .1D0,  .09D0,
33830      & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0,  .2D0,   .1D0,
33831      & .08D0, .06D0, .045D0,   .03D0, .02D0, .01D0,      .005D0, .003D0,
33832      & 12*0.D0, .3D0, .24D0,   .18D0, .15D0, .13D0,  .12D0, .11D0, .1D0,
33833      & .09D0,  .08D0, .05D0,   .04D0, .03D0,  0.D0, 0.16D0, .7D0, 1.3D0,
33834      & 3.1D0,  4.5D0,  2.D0, 18*0.D0, 3*.0D0,  0.D0, 0.D0, 4.0D0, 11.D0,
33835      & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0,  1.5D0, .9D0, .55D0,
33836      &  .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0,   2.25D0, 3.3D0,
33837      & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
33838      & .64D0,  1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0,  4.4D0,   3.D0, 1.8D0,
33839      &  .9D0, .53D0, .28D0,      10*0.D0, 2*0.D0,  .25D0,  .82D0,
33840      & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0,  5.7D0, 3.9D0, 2.35D0, 1.15D0,
33841      & .69D0, .37D0, 10*0.D0,     7*0.D0,   .0D0, .34D0,  1.5D0, 3.47D0,
33842      & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0,  .3D0,  .15D0, 6*0.D0/
33843 *
33844       DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33845      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
33846      & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
33847      & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
33848      & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
33849      & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
33850      & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
33851      & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
33852      & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
33853      & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
33854      & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
33855      & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
33856      & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
33857      & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
33858      & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
33859      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33860      & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
33861      & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
33862      & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
33863      & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
33864 **** pi- p data                                                        *
33865       DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
33866      & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33867      & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33868      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33869      & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
33870      & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
33871      & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
33872      & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
33873      & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
33874      & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
33875      & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
33876      & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
33877      & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
33878      & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
33879      & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
33880      & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
33881      & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
33882      & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
33883      & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33884 *
33885       DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33886      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
33887      & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
33888      & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
33889      & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
33890      & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
33891      & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
33892      & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
33893      & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
33894      & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
33895      & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
33896      & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
33897      & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
33898      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33899      & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
33900      & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
33901      & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
33902      & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
33903      & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
33904      & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
33905 **** pi- n data                                                        *
33906       DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
33907      & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
33908      & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
33909      & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
33910      & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
33911      & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
33912      & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
33913      & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
33914      & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
33915      & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
33916      & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
33917      & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
33918      & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
33919      & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
33920      & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
33921      & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
33922      & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
33923      & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
33924      & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
33925      & 3.3D0, 5.4D0, 7.D0 /
33926 **** k+  p data                                                        *
33927       DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
33928      & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
33929      & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
33930      & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
33931      & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33932      & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
33933      & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
33934      & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
33935      & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
33936      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33937      & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
33938      & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
33939      & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
33940 **** k+  n data                                                        *
33941       DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
33942      & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
33943      & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
33944      & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
33945      & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33946      & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
33947      & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
33948      & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
33949      & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
33950      & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
33951      & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
33952      & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
33953      & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
33954      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33955      & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
33956      & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
33957      & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
33958      & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
33959      & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
33960 **** k-  p data                                                        *
33961       DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
33962      &     7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
33963      &    0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
33964      &    .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
33965      &    0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
33966      &    .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
33967      &    0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
33968      &    .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
33969      &    0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
33970      &    .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
33971      &    0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
33972      &    .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
33973       DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
33974      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
33975      & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
33976      & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
33977      & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,  3*0.D0, 1.0D0, 3.03D0,
33978      & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
33979      & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
33980      & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
33981      & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
33982      & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
33983      & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
33984      & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
33985      & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
33986      & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
33987      & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
33988      & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
33989      & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
33990      & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
33991      & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
33992      & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
33993      & 10*0.D0/
33994 ***** k- n data                                                        *
33995       DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
33996      &        3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
33997      &        0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
33998      &        1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
33999      &        0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
34000      &        .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
34001      &        0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
34002      &       .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
34003       DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34004      &  14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
34005      &  1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
34006      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
34007      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
34008      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
34009      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
34010      &  7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
34011      &  .39D0, .22D0, .07D0, 0.D0,
34012      &  6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
34013      &  4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
34014      &  10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
34015      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34016      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34017      &  9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
34018      &  5.10D0, 5.44D0, 5.3D0,
34019      &  4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
34020 *****  p p data                                                        *
34021       DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34022      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34023      &              0.D0, 3.6D0, 1.7D0, 10*0.D0,
34024      &              .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
34025      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34026      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34027      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34028      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34029      &              16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
34030      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
34031      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
34032      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34033      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34034      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34035      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34036 *****  p n data                                                        *
34037       DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34038      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34039      &              0.D0, 1.8D0, .2D0,  12*0.D0,
34040      &              3.2D0, 6.05D0, 9.9D0, 5.1D0,
34041      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34042      &              2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34043      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34044      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34045      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34046      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34047      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34048      &              10*0.D0, .7D0, 5.1D0, 8.D0,
34049      &              10*0.D0, .7D0, 5.1D0, 8.D0,
34050      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
34051      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
34052      &              7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
34053      &              7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
34054      &              5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
34055 *   nn - data                                                          *
34056 *                                                                      *
34057       DATA SPKPV/  0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34058      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34059      &              0.D0, 3.6D0, 1.7D0, 12*0.D0,
34060      &              8.7D0, 17.7D0, 18.8D0, 15.9D0,
34061      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34062      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34063      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34064      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
34065      &              11.D0, 5.5D0, 3.5D0,
34066      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
34067      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
34068      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34069      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34070      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34071      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34072 ****************   ap - p - data                                       *
34073       DATA SAPPEL/ 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34074      &  50.D0,  50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34075      &  25.D0,  22.D0, 21.D0, 20.D0, 18.D0, 17.D0,  11*0.D0,
34076      &  .05D0,  .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34077      &  0.D0,  1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34078      &  .1D0,  .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34079      &  0.D0,  55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
34080      &  10.D0,  7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
34081      &  1.55D0,  1.3D0, .95D0, .75D0,
34082      &  0.D0,  3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34083      &  .25D0,  .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34084      & .01D0,  .008D0, .006D0, .005D0/
34085       DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34086      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34087      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
34088      & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
34089      & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
34090      & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
34091      & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
34092      & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
34093      & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
34094      & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
34095      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34096      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34097      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34098      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
34099      & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
34100      & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
34101      & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
34102      & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
34103      & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
34104      & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
34105 ****************   ap - n - data                                       *
34106       DATA SAPNEL/
34107      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0,  68.D0, 65.D0,
34108      & 50.D0, 50.D0,  43.D0,  42.D0,  40.5D0, 35.D0, 30.D0,  28.D0,
34109      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0,  17.D0, 11*0.D0,
34110      & .05D0, .15D0, .18D0,  .2D0,    .2D0,  .3D0,  .4D0,   .6D0,  .7D0,
34111      & .85D0,  0.D0,  1.D0,  .9D0,    .46D0, .3D0,  .23D0, .18D0, .16D0,
34112      & .14D0,  .1D0, .08D0, .05D0,    .02D0, .015D0, 4*.011D0, 3*.005D0,
34113      & 0.D0,  3.3D0,  3.D0, 1.5D0,     1.D0, .7D0,  .4D0,  .35D0, .4D0,
34114      & .25D0, .18D0, .08D0, .04D0,    .03D0, .023D0, .016D0, .014D0,
34115      & .01D0, .008D0, .006D0, .005D0 /
34116        DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34117      &  84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34118      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34119      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34120      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34121      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34122      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34123      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34124      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34125      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34126      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34127      & 4.9D0, 8.5D0,  15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34128      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34129      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34130 *                                                                      *
34131 *                                                                      *
34132 ****************   an - p - data                                       *
34133 *                                                                      *
34134       DATA SANPEL/
34135      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
34136      & 50.D0, 43.D0,  42.D0,  40.5D0, 35.D0, 30.D0, 28.D0,
34137      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0, 17.D0, 11*0.D0, .05D0,
34138      & .15D0, .18D0,   .2D0,   .2D0,   .3D0,  .4D0, .6D0,   .7D0, .85D0,
34139      & 0.D0,   1.D0,   .9D0,  .46D0,  .3D0,  .23D0, .18D0, .16D0, .14D0,
34140      & .1D0,  .08D0,  .05D0,  .02D0, .015D0, 4*.011D0, 3*.005D0,
34141      & 0.D0,  3.3D0,  3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
34142      & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34143      & .01D0, .008D0, .006D0, .005D0 /
34144       DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34145      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34146      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34147      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34148      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34149      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34150      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34151      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34152      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34153      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34154      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34155      & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34156      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34157      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34158 ****  ko - n - data                                                    *
34159       DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
34160      &      6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
34161      &      0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
34162      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34163      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34164      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34165      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34166      &    4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
34167      &     1.4D0, 1.2D0, 1.05D0, .9D0, .66D0,  .5D0,
34168      &    7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
34169      &   11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
34170      &    4.85D0, 4.9D0,
34171      &   10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
34172      &    6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
34173      &    2.85D0, 2.35D0, 2.01D0, 1.8D0,
34174      &   12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
34175      &   12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0  /
34176 **** ako - p - data                                                    *
34177       DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
34178      & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
34179      & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
34180      & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
34181      & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
34182      & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
34183      & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
34184      & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34185      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
34186      & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
34187      & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
34188      & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
34189      & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
34190      & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
34191      & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
34192      & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
34193      & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
34194      & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
34195      & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
34196      & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
34197      & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
34198       DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
34199      & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
34200 *=                                               end*block.blkdt3      *
34201       END
34202 *$ CREATE DT_QEL_POL.FOR
34203 *COPY DT_QEL_POL
34204 *
34205 *===qel_pol============================================================*
34206 *
34207       SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
34208
34209       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34210       SAVE
34211
34212       CALL DT_MASS_INI
34213       CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34214
34215       RETURN
34216       END
34217
34218 *$ CREATE DT_GEN_QEL.FOR
34219 *COPY DT_GEN_QEL
34220 C==================================================================
34221 C   Generation of  a Quasi-Elastic neutrino scattering
34222 C==================================================================
34223 *
34224 *===gen_qel============================================================*
34225 *
34226       SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34227
34228 C...Generate a quasi-elastic   neutrino/antineutrino
34229 C.  Interaction on a nuclear target
34230 C.  INPUT  : LTYP = neutrino type (1,...,6)
34231 C.           ENU (GeV) = neutrino energy
34232 C----------------------------------------------------
34233
34234       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34235       SAVE
34236
34237       PARAMETER ( LINP = 10 ,
34238      &            LOUT = 6 ,
34239      &            LDAT = 9 )
34240       PARAMETER (MAXLND=4000)
34241       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34242
34243 * nuclear potential
34244       LOGICAL LFERMI
34245       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
34246      &                EBINDP(2),EBINDN(2),EPOT(2,210),
34247      &                ETACOU(2),ICOUL,LFERMI
34248
34249 * steering flags for qel neutrino scattering modules
34250       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34251 **sr - removed (not needed)
34252 C     COMMON /CBAD/  LBAD, NBAD
34253 C     COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
34254 **
34255
34256       DIMENSION PI(3),PO(3)
34257 CJR+
34258       DATA ININU/0/
34259 CJR-
34260 C     REAL*8 DBETA(3)
34261 C     REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
34262       DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
34263       DATA AMN  /0.93827231D0, 0.93956563D0/
34264       DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
34265       DATA INIPRI/0/
34266
34267 C     DATA PFERMI/0.22D0/
34268 CGB+...Binding Energy
34269       DATA EBIND/0.008D0/
34270 CGB-...
34271
34272       ININU=ININU+1
34273       IF(ININU.EQ.1)NDSIG=0
34274       LBAD = 0
34275       enu0=enu
34276 c      write(*,*) enu0
34277 C...Lepton mass
34278       AML = AML0(LTYP)       !  massa leptoni
34279       AML2 = AML**2          !  massa leptoni **2
34280 C...Particle labels (LUND)
34281       N = 5
34282       K(1,1) = 21
34283       K(2,1) = 21
34284       K(3,1) = 21
34285       K(3,3) = 1
34286       K(4,1) = 1
34287       K(4,3) = 1
34288       K(5,1) = 1
34289       K(5,3) = 2
34290       K0 = (LTYP-1)/2          !  2
34291       K1 = LTYP/2              !  2
34292       KA = 12 + 2*K0           !  16
34293       IS = -1 + 2*LTYP - 4*K1  !  -1 +10 -8 = 1
34294       K(1,2) = IS*KA
34295       K(4,2) = IS*(KA-1)
34296       K(3,2) = IS*24
34297       LNU = 2 - LTYP + 2*K1    !  2 - 5 + 2 = - 1
34298       IF (LNU .EQ. 2)  THEN
34299         K(2,2) = 2212
34300         K(5,2) = 2112
34301         AMI = AMN(1)
34302         AMF = AMN(2)
34303 CJR+
34304         PFERMI=PFERMN(2)
34305 CJR-
34306       ELSE
34307         K(2,2) = 2112
34308         K(5,2) = 2212
34309         AMI = AMN(2)
34310         AMF = AMN(1)
34311 CJR+
34312         PFERMI=PFERMP(2)
34313 CJR-
34314       ENDIF
34315       AMI2 = AMI**2
34316       AMF2 = AMF**2
34317
34318       DO IGB=1,5
34319         P(3,IGB) = 0.
34320         P(4,IGB) = 0.
34321         P(5,IGB) = 0.
34322       END DO
34323
34324       NTRY = 0
34325 CGB+...
34326       EFMAX  = SQRT(PFERMI**2 + AMI2) -AMI             ! max. Fermi Energy
34327       ENWELL = EFMAX + EBIND ! depth of nuclear potential well
34328 CGB-...
34329
34330   100 CONTINUE
34331
34332 C...4-momentum initial lepton
34333       P(1,5) = 0.     ! massa
34334       P(1,4) = ENU0    ! energia
34335       P(1,1) = 0.     ! px
34336       P(1,2) = 0.     ! py
34337       P(1,3) = ENU0    ! pz
34338
34339 C     PF = PFERMI*PYR(0)**(1./3.)
34340 c       write(23,*) PYR(0)
34341 c      write(*,*) 'Pfermi=',PF
34342 c      PF = 0.
34343       NTRY=NTRY+1
34344 C     IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
34345       IF (NTRY .GT. 500)  THEN
34346         LBAD = 1
34347         WRITE (LOUT,1001)  NBAD, ENU
34348         RETURN
34349       ENDIF
34350 C     CT = -1. + 2.*PYR(0)
34351 c      CT = -1.
34352 C     ST =  SQRT(1.-CT*CT)
34353 C     F = 2.*3.1415926*PYR(0)
34354 c      F = 0.
34355
34356 C     P(2,4) = SQRT(PF*PF + MI2) - EBIND  ! energia
34357 C     P(2,1) = PF*ST*COS(F)               ! px
34358 C     P(2,2) = PF*ST*SIN(F)               ! py
34359 C     P(2,3) = PF*CT                      ! pz
34360 C     P(2,5) = SQRT(P(2,4)**2-PF*PF)      ! massa
34361        P(2,1) = P21
34362        P(2,2) = P22
34363        P(2,3) = P23
34364        P(2,4) = P24
34365        P(2,5) = P25
34366       beta1=-p(2,1)/p(2,4)
34367       beta2=-p(2,2)/p(2,4)
34368       beta3=-p(2,3)/p(2,4)
34369       N=2
34370 C      WRITE(6,*)' before transforming into target rest frame'
34371
34372       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
34373
34374 C      print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
34375       N=5
34376
34377       phi11=atan(p(1,2)/p(1,3))
34378       pi(1)=p(1,1)
34379       pi(2)=p(1,2)
34380       pi(3)=p(1,3)
34381
34382       CALL DT_TESTROT(PI,Po,PHI11,1)
34383       DO ll=1,3
34384         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34385       END DO
34386 c        WRITE(*,*) po
34387       p(1,1)=po(1)
34388       p(1,2)=po(2)
34389       p(1,3)=po(3)
34390       phi12=atan(p(1,1)/p(1,3))
34391
34392       pi(1)=p(1,1)
34393       pi(2)=p(1,2)
34394       pi(3)=p(1,3)
34395       CALL DT_TESTROT(Pi,Po,PHI12,2)
34396       DO ll=1,3
34397         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34398       END DO
34399 c        WRITE(*,*) po
34400       p(1,1)=po(1)
34401       p(1,2)=po(2)
34402       p(1,3)=po(3)
34403
34404       enu=p(1,4)
34405
34406 C...Kinematical limits in Q**2
34407 c      S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) !            ????
34408       S = P(2,5)**2 + 2.*ENU*P(2,5)
34409       SQS = SQRT(S)                          ! E centro massa
34410       IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
34411       ELF = (S-AMF2+AML2)/(2.*SQS)           ! energia leptone finale p
34412       PSTAR = (S-P(2,5)**2)/(2.*SQS)       ! p* neutrino nel c.m.
34413       PLF = SQRT(ELF**2-AML2)               ! 3-momento leptone finale
34414       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)    ! + o -
34415       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)    ! according con cos(theta)
34416       IF (Q2MIN .LT. 0.)   Q2MIN = 0.      ! ??? non fisico
34417
34418 C...Generate Q**2
34419       DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
34420   200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
34421       DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
34422       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
34423       CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
34424       NDSIG=NDSIG+1
34425 C     WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
34426 C    &Q2,Q2min,Q2MAX,DSIGEV
34427
34428 C...c.m. frame. Neutrino along z axis
34429       DETOT = (P(1,4)) + (P(2,4)) ! e totale
34430       DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
34431       DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
34432       DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
34433 c      WRITE(*,*)
34434 c      WRITE(*,*)
34435 C      WRITE(*,*) 'Input values laboratory frame'
34436       N=2
34437
34438       CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
34439
34440       N=5
34441 c      STHETA = ULANGL(P(1,3),P(1,1))
34442 c      write(*,*) 'stheta' ,stheta
34443 c      stheta=0.
34444 c      CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
34445 c      WRITE(*,*)
34446 c      WRITE(*,*)
34447 C      WRITE(*,*) 'Output values cm frame'
34448 C...Kinematic in c.m. frame
34449       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
34450       STSTAR = SQRT(1.-CTSTAR**2)
34451       PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
34452       P(4,5) = AML                  ! massa leptone
34453       P(4,4) = ELF                 ! e leptone
34454       P(4,3) = PLF*CTSTAR          ! px
34455       P(4,1) = PLF*STSTAR*COS(PHI) ! py
34456       P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
34457
34458       P(5,5) = AMF                  ! barione
34459       P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
34460       P(5,3) = -P(4,3)             ! px
34461       P(5,1) = -P(4,1)             ! py
34462       P(5,2) = -P(4,2)             ! pz
34463
34464       P(3,5) = -Q2
34465       P(3,1) = P(1,1)-P(4,1)
34466       P(3,2) = P(1,2)-P(4,2)
34467       P(3,3) = P(1,3)-P(4,3)
34468       P(3,4) = P(1,4)-P(4,4)
34469
34470 C...Transform back to laboratory  frame
34471 C      WRITE(*,*) 'before going back to nucl rest frame'
34472 c      CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
34473       N=5
34474
34475       CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
34476
34477 C      WRITE(*,*) 'Now back in nucl rest frame'
34478       IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
34479
34480 c********************************************
34481
34482       DO kw=1,5
34483         pi(1)=p(kw,1)
34484         pi(2)=p(kw,2)
34485         pi(3)=p(kw,3)
34486         CALL DT_TESTROT(Pi,Po,PHI12,3)
34487         DO ll=1,3
34488           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34489         END DO
34490         p(kw,1)=po(1)
34491         p(kw,2)=po(2)
34492         p(kw,3)=po(3)
34493       END DO
34494 c********************************************
34495
34496       DO kw=1,5
34497         pi(1)=p(kw,1)
34498         pi(2)=p(kw,2)
34499         pi(3)=p(kw,3)
34500         CALL DT_TESTROT(Pi,Po,PHI11,4)
34501         DO ll=1,3
34502           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34503         END DO
34504         p(kw,1)=po(1)
34505         p(kw,2)=po(2)
34506         p(kw,3)=po(3)
34507       END DO
34508
34509 c********************************************
34510
34511 C      WRITE(*,*) 'Now back in lab frame'
34512
34513       CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
34514
34515 CGB+...
34516 C...test (on final momentum of nucleon) if Fermi-blocking
34517 C...is operating
34518       ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
34519      &  - P(5,5)
34520       IF (ENUCL.LT. EFMAX) THEN
34521         IF(INIPRI.LT.10)THEN
34522           INIPRI=INIPRI+1
34523 C         WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
34524 C...the interaction is not possible due to Pauli-Blocking and
34525 C...it must be resampled
34526         ENDIF
34527         GOTO 100
34528       ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
34529         IF(INIPRI.LT.10)THEN
34530           INIPRI=INIPRI+1
34531 C     WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
34532         ENDIF
34533 C                      Reject (J:R) here all these events
34534 C                      are otherwise rejected in dpmjet
34535         GOTO 100
34536 C...the interaction is possible, but the nucleon remains inside
34537 C...the nucleus. The nucleus is therefore left excited.
34538 C...We treat this case as a nucleon with 0 kinetic energy.
34539 C       P(5,5) = AMF
34540 C       P(5,4) = AMF
34541 C       P(5,1) = 0.
34542 C       P(5,2) = 0.
34543 C       P(5,3) = 0.
34544       ELSE IF (ENUCL.GE.ENWELL) THEN
34545 C     WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
34546 C...the interaction is possible, the nucleon can exit the nucleus
34547 C...but the nuclear well depth must be subtracted. The nucleus could be
34548 C...left in an excited state.
34549         Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
34550 C       P(5,4) = ENUCL-ENWELL + AMF
34551         Pnucl = SQRT(P(5,4)**2-AMF**2)
34552 C...The 3-momentum is scaled assuming that the direction remains
34553 C...unaffected
34554         P(5,1) = P(5,1) * Pnucl/Pstart
34555         P(5,2) = P(5,2) * Pnucl/Pstart
34556         P(5,3) = P(5,3) * Pnucl/Pstart
34557 C     WRITE(6,*)' qel new P(5,4) ',P(5,4)
34558       ENDIF
34559 CGB-...
34560       DSIGSU=DSIGSU+DSIGEV
34561
34562          GA=P(4,4)/P(4,5)
34563          BGX=P(4,1)/P(4,5)
34564          BGY=P(4,2)/P(4,5)
34565          BGZ=P(4,3)/P(4,5)
34566 *
34567          DBETB(1)=BGX/GA
34568          DBETB(2)=BGY/GA
34569          DBETB(3)=BGZ/GA
34570          IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
34571
34572             CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
34573
34574          ENDIF
34575 c
34576 C      PRINT*,' FINE   EVENTO '
34577       enu=enu0
34578       RETURN
34579
34580  1001 FORMAT(2X, 'DT_GEN_QEL   : event rejected ', I5,  G10.3)
34581       END
34582
34583 *$ CREATE DT_MASS_INI.FOR
34584 *COPY DT_MASS_INI
34585 C====================================================================
34586 C.  Masses
34587 C====================================================================
34588 *
34589 *===mass_ini===========================================================*
34590 *
34591       SUBROUTINE DT_MASS_INI
34592 C...Initialize  the kinematics for the quasi-elastic cross section
34593
34594       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34595       SAVE
34596
34597 * particle masses used in qel neutrino scattering modules
34598       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34599      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34600      &                EMPROTSQ,EMNEUTSQ,EMNSQ
34601
34602       EML(1) = 0.51100D-03   ! e-
34603       EML(2) = EML(1)        ! e+
34604       EML(3) = 0.105659D0      ! mu-
34605       EML(4) = EML(3)        ! mu+
34606       EML(5) = 1.7777D0        ! tau-
34607       EML(6) = EML(5)        ! tau+
34608       EMPROT = 0.93827231D0    ! p
34609       EMNEUT = 0.93956563D0    ! n
34610       EMPROTSQ = EMPROT**2
34611       EMNEUTSQ = EMNEUT**2
34612       EMN = (EMPROT + EMNEUT)/2.
34613       EMNSQ = EMN**2
34614       DO J=1,3
34615         J0 = 2*(J-1)
34616         EMN1(J0+1) = EMNEUT
34617         EMN1(J0+2) = EMPROT
34618         EMN2(J0+1) = EMPROT
34619         EMN2(J0+2) = EMNEUT
34620       ENDDO
34621       DO J=1,6
34622         EMLSQ(J) = EML(J)**2
34623         ETQE(J)  = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
34624       ENDDO
34625       RETURN
34626       END
34627
34628 *$ CREATE DT_DSQEL_Q2.FOR
34629 *COPY DT_DSQEL_Q2
34630 *
34631 *===dsqel_q2===========================================================*
34632 *
34633       DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
34634
34635 C...differential cross section for  Quasi-Elastic scattering
34636 C.       nu + N -> l + N'
34637 C.  From Llewellin Smith  Phys.Rep.  3C, 261, (1971).
34638 C.
34639 C.  INPUT :  JTYP = 1,...,6    nu_e, ...., nubar_tau
34640 C.           ENU (GeV) =  Neutrino energy
34641 C.           Q2  (GeV**2) =  (Transfer momentum)**2
34642 C.
34643 C.  OUTPUT : DSQEL_Q2  = differential  cross section :
34644 C.                       dsigma/dq**2  (10**-38 cm+2/GeV**2)
34645 C------------------------------------------------------------------
34646
34647       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34648       SAVE
34649
34650 * particle masses used in qel neutrino scattering modules
34651       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34652      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34653      &                EMPROTSQ,EMNEUTSQ,EMNSQ
34654 **sr - removed (not needed)
34655 C     COMMON /CAXIAL/ FA0, AXIAL2
34656 **
34657
34658       DIMENSION SS(6)
34659       DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34660       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34661       DATA AXIAL2 /1.03D0/  ! to be checked
34662
34663       FA0=-1.253D0
34664       CSI = 3.71D0                   !  ???
34665       GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2   ! G_e(q**2)
34666       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
34667       X = Q2/(EMN*EMN)     ! emn=massa barione
34668       XA = X/4.D0
34669       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34670       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34671       FA = FA0/(1.D0 + Q2/AXIAL2)**2
34672       FFA = FA*FA
34673       FFV1 = FV1*FV1
34674       FFV2 = FV2*FV2
34675       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
34676       A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
34677       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
34678       AA = (XA+0.25D0*RM)*(A1 + A2)
34679       BB = -X*FA*(FV1 + FV2)
34680       CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
34681       SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34682       DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU)  !
34683       IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
34684
34685       RETURN
34686       END
34687
34688 *$ CREATE DT_PREPOLA.FOR
34689 *COPY DT_PREPOLA
34690 *
34691 *===prepola============================================================*
34692 *
34693       SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
34694
34695       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34696       SAVE
34697 c
34698 c By G. Battistoni and E. Scapparone (sept. 1997)
34699 c According to:
34700 c     Albright & Jarlskog, Nucl Phys B84 (1975) 467
34701 c
34702 c
34703       PARAMETER (MAXLND=4000)
34704       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34705
34706       COMMON /QNPOL/ POLARX(4),PMODUL
34707
34708 * particle masses used in qel neutrino scattering modules
34709       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34710      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34711      &                EMPROTSQ,EMNEUTSQ,EMNSQ
34712
34713 * steering flags for qel neutrino scattering modules
34714       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34715 **sr - removed (not needed)
34716 C     COMMON /CAXIAL/ FA0, AXIAL2
34717 C     COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
34718 C    &        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
34719 **
34720       REAL*8 POL(4,4),BB2(3)
34721       DIMENSION SS(6)
34722 C     DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34723       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34724 **sr uncommented since common block CAXIAL is now commented
34725       DATA AXIAL2 /1.03D0/  ! to be checked
34726 **
34727
34728       RML=P(4,5)
34729       RMM=0.93960D+00
34730       FM2 = RMM**2
34731       MPI = 0.135D+00
34732       OLDQ2=Q2
34733       FA0=-1.253D+00
34734       CSI = 3.71D+00                      !
34735       GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2   ! G_e(q**2)
34736       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
34737       X = Q2/(EMN*EMN)     ! emn=massa barione
34738       XA = X/4.D0
34739       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34740       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34741       FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
34742       FFA = FA*FA
34743       FFV1 = FV1*FV1
34744       FFV2 = FV2*FV2
34745       FP=2.D0*FA*RMM/(MPI**2 + Q2)
34746       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
34747       A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
34748       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
34749       AA = (XA+0.25D+00*RM)*(A1 + A2)
34750       BB = -X*FA*(FV1 + FV2)
34751       CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
34752       SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34753
34754       OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2   )  ! articolo di ll...-smith
34755       OMEGA2=4.D+00*CC
34756       OMEGA3=2.D+00*FA*(FV1+FV2)
34757       OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
34758      1     (Q2/FM2))*FP**2)
34759       OMEGA5=OMEGA2
34760       OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
34761       WW1=2.D+00*OMEGA1*EMN**2
34762       WW2=2.D+00*OMEGA2*EMN**2
34763       WW3=2.D+00*OMEGA3*EMN**2
34764       WW4=2.D+00*OMEGA4*EMN**2
34765       WW5=2.D+00*OMEGA5*EMN**2
34766
34767       DO I=1,3
34768         BB2(I)=-P(4,I)/P(4,4)
34769       END DO
34770 c      WRITE(*,*)
34771 c      WRITE(*,*)
34772 c      WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
34773       N=5
34774
34775       CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
34776
34777 * NOW PARTICLES ARE IN THE SCATTERED LEPTON  REST FRAME
34778 c      WRITE(*,*)
34779 c      WRITE(*,*)
34780 c      WRITE(*,*) 'Prepola: now in lepton rest frame'
34781       EE=ENU
34782       QM2=Q2+RML**2
34783       U=Q2/(2.*RMM)
34784       FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
34785      +     (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
34786      +     ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
34787
34788       FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
34789      +     - ((RML**2)/FM2)*WW4                        !<=FM2 inv di RMM!!
34790
34791       FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
34792
34793       DO I=1,3
34794         POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
34795         POLARX(I)=POL(4,I)
34796       END DO
34797
34798       PMODUL=0.D0
34799       DO I=1,3
34800         PMODUL=PMODUL+POL(4,I)**2
34801       END DO
34802
34803       IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
34804          IF(NEUDEC.EQ.1) THEN
34805             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
34806      +        ETL,PXL,PYL,PZL,
34807      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34808 c
34809 c     Tau has decayed in muon
34810 c
34811          ENDIF
34812          IF(NEUDEC.EQ.2) THEN
34813             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
34814      +        ETL,PXL,PYL,PZL,
34815      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34816 c
34817 c     Tau has decayed in electron
34818 c
34819          ENDIF
34820          K(4,1)=15
34821          K(4,4) = 6
34822          K(4,5) = 8
34823          N=N+3
34824 c
34825 c     fill common for muon(electron)
34826 c
34827          P(6,1)=PXL
34828          P(6,2)=PYL
34829          P(6,3)=PZL
34830          P(6,4)=ETL
34831          K(6,1)=1
34832          IF(JTYP.EQ.5) THEN
34833             IF(NEUDEC.EQ.1) THEN
34834                P(6,5)=EML(JTYP-2)
34835                K(6,2)=13
34836             ELSEIF(NEUDEC.EQ.2) THEN
34837                P(6,5)=EML(JTYP-4)
34838                K(6,2)=11
34839             ENDIF
34840          ELSEIF(JTYP.EQ.6) THEN
34841             IF(NEUDEC.EQ.1) THEN
34842                K(6,2)=-13
34843             ELSEIF(NEUDEC.EQ.2) THEN
34844                K(6,2)=-11
34845             ENDIF
34846          END IF
34847          K(6,3)=4
34848          K(6,4)=0
34849          K(6,5)=0
34850 c
34851 c     fill common for tau_(anti)neutrino
34852 c
34853          P(7,1)=PXB
34854          P(7,2)=PYB
34855          P(7,3)=PZB
34856          P(7,4)=ETB
34857          P(7,5)=0.
34858          K(7,1)=1
34859          IF(JTYP.EQ.5) THEN
34860             K(7,2)=16
34861          ELSEIF(JTYP.EQ.6) THEN
34862             K(7,2)=-16
34863          END IF
34864          K(7,3)=4
34865          K(7,4)=0
34866          K(7,5)=0
34867 c
34868 c     Fill common for muon(electron)_(anti)neutrino
34869 c
34870          P(8,1)=PXN
34871          P(8,2)=PYN
34872          P(8,3)=PZN
34873          P(8,4)=ETN
34874          P(8,5)=0.
34875          K(8,1)=1
34876          IF(JTYP.EQ.5) THEN
34877             IF(NEUDEC.EQ.1) THEN
34878                K(8,2)=-14
34879             ELSEIF(NEUDEC.EQ.2) THEN
34880                K(8,2)=-12
34881             ENDIF
34882          ELSEIF(JTYP.EQ.6) THEN
34883             IF(NEUDEC.EQ.1) THEN
34884                K(8,2)=14
34885             ELSEIF(NEUDEC.EQ.2) THEN
34886                K(8,2)=12
34887             ENDIF
34888          END IF
34889          K(8,3)=4
34890          K(8,4)=0
34891          K(8,5)=0
34892       ENDIF
34893 c      WRITE(*,*)
34894 c      WRITE(*,*)
34895
34896 c      IF(PMODUL.GE.1.D+00) THEN
34897 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34898 c        write(*,*) pmodul
34899 c        DO I=1,3
34900 c          POL(4,I)=POL(4,I)/PMODUL
34901 c          POLARX(I)=POL(4,I)
34902 c        END DO
34903 c        PMODUL=0.
34904 c        DO I=1,3
34905 c          PMODUL=PMODUL+POL(4,I)**2
34906 c        END DO
34907 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34908 c
34909 c      ENDIF
34910
34911 c      WRITE(*,*) 'PMODUL = ',PMODUL
34912
34913 c      WRITE(*,*)
34914 c      WRITE(*,*)
34915 c      WRITE(*,*) 'prepola: Now back to nucl rest frame'
34916
34917       CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
34918
34919       XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
34920       YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
34921       ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
34922       DO NDC =6,8
34923          V(NDC,1) = XDC
34924          V(NDC,2) = YDC
34925          V(NDC,3) = ZDC
34926       END DO
34927
34928       RETURN
34929       END
34930
34931 *$ CREATE DT_TESTROT.FOR
34932 *COPY DT_TESTROT
34933 *
34934 *===testrot============================================================*
34935 *
34936       SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
34937
34938       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34939       SAVE
34940
34941       DIMENSION ROT(3,3),PI(3),PO(3)
34942
34943       IF (MODE.EQ.1) THEN
34944          ROT(1,1) = 1.D0
34945          ROT(1,2) = 0.D0
34946          ROT(1,3) = 0.D0
34947          ROT(2,1) = 0.D0
34948          ROT(2,2) = COS(PHI)
34949          ROT(2,3) = -SIN(PHI)
34950          ROT(3,1) = 0.D0
34951          ROT(3,2) = SIN(PHI)
34952          ROT(3,3) = COS(PHI)
34953       ELSEIF (MODE.EQ.2) THEN
34954          ROT(1,1) = 0.D0
34955          ROT(1,2) = 1.D0
34956          ROT(1,3) = 0.D0
34957          ROT(2,1) = COS(PHI)
34958          ROT(2,2) = 0.D0
34959          ROT(2,3) = -SIN(PHI)
34960          ROT(3,1) = SIN(PHI)
34961          ROT(3,2) = 0.D0
34962          ROT(3,3) = COS(PHI)
34963       ELSEIF (MODE.EQ.3) THEN
34964          ROT(1,1) = 0.D0
34965          ROT(2,1) = 1.D0
34966          ROT(3,1) = 0.D0
34967          ROT(1,2) = COS(PHI)
34968          ROT(2,2) = 0.D0
34969          ROT(3,2) = -SIN(PHI)
34970          ROT(1,3) = SIN(PHI)
34971          ROT(2,3) = 0.D0
34972          ROT(3,3) = COS(PHI)
34973       ELSEIF (MODE.EQ.4) THEN
34974          ROT(1,1) = 1.D0
34975          ROT(2,1) = 0.D0
34976          ROT(3,1) = 0.D0
34977          ROT(1,2) = 0.D0
34978          ROT(2,2) = COS(PHI)
34979          ROT(3,2) = -SIN(PHI)
34980          ROT(1,3) = 0.D0
34981          ROT(2,3) = SIN(PHI)
34982          ROT(3,3) = COS(PHI)
34983       ELSE
34984          STOP ' TESTROT: mode not supported!'
34985       ENDIF
34986       DO 1 J=1,3
34987         PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
34988     1 CONTINUE
34989
34990       RETURN
34991       END
34992
34993 *$ CREATE DT_LEPDCYP.FOR
34994 *COPY DT_LEPDCYP
34995 *
34996 *===lepdcyp============================================================*
34997 *
34998       SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
34999      &                      ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
35000 C
35001 C-----------------------------------------------------------------
35002 C
35003 C   Author   :- G. Battistoni         10-NOV-1995
35004 C
35005 C=================================================================
35006 C
35007 C   Purpose   : performs decay of polarized lepton in
35008 C               its rest frame: a => b + l + anti-nu
35009 C               (Example: mu- => nu-mu + e- + anti-nu-e)
35010 C               Polarization is assumed along Z-axis
35011 C               WARNING:
35012 C               1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
35013 C                  OF NEGLIGIBLE MASS
35014 C               2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
35015 C                  IN THIS VERSION
35016 C
35017 C   Method    : modifies phase space distribution obtained
35018 C               by routine EXPLOD using a rejection against the
35019 C               matrix element for unpolarized lepton decay
35020 C
35021 C   Inputs    : Mass of a :  AMA
35022 C               Mass of l :  AML
35023 C               Polar. of a: POL
35024 C               (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
35025 C                                                 POL = -1)
35026 C
35027 C   Outputs   : kinematic variables in the rest frame of decaying lepton
35028 C               ETL,PXL,PYL,PZL 4-moment of l
35029 C               ETB,PXB,PYB,PZB 4-moment of b
35030 C               ETN,PXN,PYN,PZN 4-moment of anti-nu
35031 C
35032 C============================================================
35033 C +
35034 C Declarations.
35035 C -
35036       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35037       SAVE
35038
35039       PARAMETER ( LINP = 10 ,
35040      &            LOUT = 6 ,
35041      &            LDAT = 9 )
35042
35043       PARAMETER ( KALGNM = 2 )
35044       PARAMETER ( ANGLGB = 5.0D-16 )
35045       PARAMETER ( ANGLSQ = 2.5D-31 )
35046       PARAMETER ( AXCSSV = 0.2D+16 )
35047       PARAMETER ( ANDRFL = 1.0D-38 )
35048       PARAMETER ( AVRFLW = 1.0D+38 )
35049       PARAMETER ( AINFNT = 1.0D+30 )
35050       PARAMETER ( AZRZRZ = 1.0D-30 )
35051       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
35052       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
35053       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
35054       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
35055       PARAMETER ( CSNNRM = 2.0D-15 )
35056       PARAMETER ( DMXTRN = 1.0D+08 )
35057       PARAMETER ( ZERZER = 0.D+00 )
35058       PARAMETER ( ONEONE = 1.D+00 )
35059       PARAMETER ( TWOTWO = 2.D+00 )
35060       PARAMETER ( THRTHR = 3.D+00 )
35061       PARAMETER ( FOUFOU = 4.D+00 )
35062       PARAMETER ( FIVFIV = 5.D+00 )
35063       PARAMETER ( SIXSIX = 6.D+00 )
35064       PARAMETER ( SEVSEV = 7.D+00 )
35065       PARAMETER ( EIGEIG = 8.D+00 )
35066       PARAMETER ( ANINEN = 9.D+00 )
35067       PARAMETER ( TENTEN = 10.D+00 )
35068       PARAMETER ( HLFHLF = 0.5D+00 )
35069       PARAMETER ( ONETHI = ONEONE / THRTHR )
35070       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
35071       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
35072       PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
35073       PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
35074       PARAMETER ( CLIGHT = 2.99792458         D+10 )
35075       PARAMETER ( AVOGAD = 6.0221367          D+23 )
35076       PARAMETER ( AMELGR = 9.1093897          D-28 )
35077       PARAMETER ( PLCKBR = 1.05457266         D-27 )
35078       PARAMETER ( ELCCGS = 4.8032068          D-10 )
35079       PARAMETER ( ELCMKS = 1.60217733         D-19 )
35080       PARAMETER ( AMUGRM = 1.6605402          D-24 )
35081       PARAMETER ( AMMUMU = 0.113428913        D+00 )
35082       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
35083       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
35084       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
35085       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
35086       PARAMETER ( PLABRC = 0.197327053        D+00 )
35087       PARAMETER ( AMELCT = 0.51099906         D-03 )
35088       PARAMETER ( AMUGEV = 0.93149432         D+00 )
35089       PARAMETER ( AMMUON = 0.105658389        D+00 )
35090       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
35091       PARAMETER ( GEVMEV = 1.0                D+03 )
35092       PARAMETER ( EMVGEV = 1.0                D-03 )
35093       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
35094       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
35095       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
35096 C +
35097 C    variables for EXPLOD
35098 C -
35099       PARAMETER ( KPMX = 10 )
35100       DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
35101      &          PZEXPL (KPMX), ETEXPL (KPMX)
35102 C +
35103 C      test variables
35104 C -
35105 **sr - removed (not needed)
35106 C     COMMON /GBATNU/ ELERAT,NTRY
35107 **
35108 C +
35109 C     Initializes test variables
35110 C -
35111       NTRY = 0
35112       ELERAT = 0.D+00
35113 C +
35114 C     Maximum value for matrix element
35115 C -
35116       ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
35117      &  SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
35118 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
35119 C     Inputs for EXPLOD
35120 C part. no. 1 is l       (e- in mu- decay)
35121 C part. no. 2 is b       (nu-mu in mu- decay)
35122 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
35123 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
35124       NPEXPL = 3
35125       ETOTEX = AMA
35126       AMEXPL(1) = AML
35127       AMEXPL(2) = 0.D+00
35128       AMEXPL(3) = 0.D+00
35129 C +
35130 C     phase space distribution
35131 C -
35132   100 CONTINUE
35133       NTRY = NTRY + 1
35134
35135       CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
35136      &              PYEXPL, PZEXPL )
35137
35138 C +
35139 C  Calculates matrix element:
35140 C  64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
35141 C  Here CTH is the cosine of the angle between anti-nu and Z axis
35142 C -
35143       CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
35144      &  PZEXPL(3)**2 )
35145       PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
35146       PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
35147      &     PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
35148       ELEMAT = 16.D+00 * PROD1 * PROD2
35149       IF(ELEMAT.GT.ELEMAX) THEN
35150         WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
35151         STOP
35152       ENDIF
35153 C +
35154 C     Here performs the rejection
35155 C -
35156       TEST = DT_RNDM(ETOTEX) * ELEMAX
35157       IF ( TEST .GT. ELEMAT ) GO TO 100
35158 C +
35159 C     final assignment of variables
35160 C -
35161       ELERAT = ELEMAT/ELEMAX
35162       ETL = ETEXPL(1)
35163       PXL = PXEXPL(1)
35164       PYL = PYEXPL(1)
35165       PZL = PZEXPL(1)
35166       ETB = ETEXPL(2)
35167       PXB = PXEXPL(2)
35168       PYB = PYEXPL(2)
35169       PZB = PZEXPL(2)
35170       ETN = ETEXPL(3)
35171       PXN = PXEXPL(3)
35172       PYN = PYEXPL(3)
35173       PZN = PZEXPL(3)
35174   999 RETURN
35175       END
35176
35177 *$ CREATE DT_GEN_DELTA.FOR
35178 *COPY DT_GEN_DELTA
35179 C==================================================================
35180 C.  Generation of  Delta resonance events
35181 C==================================================================
35182 *
35183 *===gen_delta==========================================================*
35184 *
35185       SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
35186
35187       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35188       SAVE
35189
35190       PARAMETER ( LINP = 10 ,
35191      &            LOUT = 6 ,
35192      &            LDAT = 9 )
35193
35194 C...Generate a Delta-production neutrino/antineutrino
35195 C.  CC-interaction on a nucleon
35196 C
35197 C.  INPUT  ENU (GeV) = Neutrino Energy
35198 C.         LLEP = neutrino type
35199 C.         LTARG = nucleon target type 1=p, 2=n.
35200 C.         JINT = 1:CC, 2::NC
35201 C.
35202 C.  OUTPUT PPL(4)  4-monentum of final lepton
35203 C----------------------------------------------------
35204       PARAMETER (MAXLND=4000)
35205       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35206
35207 **sr - removed (not needed)
35208 C     COMMON /CBAD/  LBAD, NBAD
35209 **
35210
35211       DIMENSION PI(3),PO(3)
35212 C     REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
35213       DIMENSION AML0(6),AMN(2)
35214       DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
35215       DATA AMN  /0.93827231, 0.93956563/
35216       DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
35217
35218 c     WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
35219       LBAD = 0
35220 C...Final lepton mass
35221       IF (JINT.EQ.1) THEN
35222         AML = AML0(LLEP)
35223       ELSE
35224         AML = 0.
35225       ENDIF
35226       AML2 = AML**2
35227
35228 C...Particle labels (LUND)
35229       N = 5
35230       K(1,1) = 21
35231       K(2,1) = 21
35232       K(3,1) = 21
35233       K(4,1) = 1
35234       K(3,3) = 1
35235       K(4,3) = 1
35236       IF (LTARG .EQ. 1)  THEN
35237          K(2,2) = 2212
35238       ELSE
35239          K(2,2) = 2112
35240       ENDIF
35241       K0 = (LLEP-1)/2
35242       K1 = LLEP/2
35243       KA = 12 + 2*K0
35244       IS = -1 + 2*LLEP - 4*K1
35245       LNU = 2 - LLEP + 2*K1
35246       K(1,2) = IS*KA
35247       K(5,1) = 1
35248       K(5,3) = 2
35249       IF (JINT .EQ. 1)  THEN                    ! CC interactions
35250          K(3,2) = IS*24
35251          K(4,2) = IS*(KA-1)
35252         IF(LNU.EQ.1) THEN
35253           IF (LTARG .EQ. 1)  THEN
35254               K(5,2) = 2224
35255           ELSE
35256               K(5,2) = 2214
35257           ENDIF
35258         ELSE
35259           IF (LTARG .EQ. 1)  THEN
35260               K(5,2) = 2114
35261           ELSE
35262               K(5,2) = 1114
35263           ENDIF
35264         ENDIF
35265       ELSE
35266          K(3,2) = 23                           ! NC (Z0) interactions
35267          K(4,2) = K(1,2)
35268 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
35269 *                                Delta0 for neutron (LTARG=2)
35270 C        IF (LTARG .EQ. 1)  THEN
35271 C           K(5,2) = 2114
35272 C        ELSE
35273 C           K(5,2) = 2214
35274 C        ENDIF
35275          IF (LTARG .EQ. 1)  THEN
35276             K(5,2) = 2214
35277          ELSE
35278             K(5,2) = 2114
35279          ENDIF
35280 **
35281       ENDIF
35282
35283 C...4-momentum initial lepton
35284       P(1,5) = 0.
35285       P(1,4) = ENU
35286       P(1,1) = 0.
35287       P(1,2) = 0.
35288       P(1,3) = ENU
35289 C...4-momentum initial nucleon
35290       P(2,5) = AMN(LTARG)
35291 C     P(2,4) = P(2,5)
35292 C     P(2,1) = 0.
35293 C     P(2,2) = 0.
35294 C     P(2,3) = 0.
35295        P(2,1) = P21
35296        P(2,2) = P22
35297        P(2,3) = P23
35298        P(2,4) = P24
35299        P(2,5) = P25
35300       N=2
35301       beta1=-p(2,1)/p(2,4)
35302       beta2=-p(2,2)/p(2,4)
35303       beta3=-p(2,3)/p(2,4)
35304       N=2
35305
35306       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35307
35308 C     print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35309
35310       phi11=atan(p(1,2)/p(1,3))
35311       pi(1)=p(1,1)
35312       pi(2)=p(1,2)
35313       pi(3)=p(1,3)
35314
35315       CALL DT_TESTROT(PI,Po,PHI11,1)
35316       DO ll=1,3
35317        IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35318       END DO
35319       p(1,1)=po(1)
35320       p(1,2)=po(2)
35321       p(1,3)=po(3)
35322       phi12=atan(p(1,1)/p(1,3))
35323
35324       pi(1)=p(1,1)
35325       pi(2)=p(1,2)
35326       pi(3)=p(1,3)
35327       CALL DT_TESTROT(Pi,Po,PHI12,2)
35328       DO ll=1,3
35329         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35330       END DO
35331       p(1,1)=po(1)
35332       p(1,2)=po(2)
35333       p(1,3)=po(3)
35334
35335       ENUU=P(1,4)
35336
35337 C...Generate the Mass of the Delta
35338       NTRY = 0
35339 100   R = PYR(0)
35340       AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
35341       NTRY = NTRY + 1
35342       IF (NTRY .GT. 1000)  THEN
35343          LBAD = 1
35344          WRITE (LOUT,1001)  NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
35345          RETURN
35346       ENDIF
35347       IF (AMD .LT. AMDMIN)  GOTO 100
35348       ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
35349       IF (ENUU .LT. ET) GOTO 100
35350
35351 C...Kinematical  limits in Q**2
35352       S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
35353       SQS = SQRT(S)
35354       PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
35355       ELF = (S - AMD**2 + AML2)/(2.*SQS)
35356       PLF = SQRT(ELF**2 - AML2)
35357       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
35358       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
35359       IF (Q2MIN .LT. 0.)   Q2MIN = 0.
35360
35361       DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
35362 200   Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35363       DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
35364       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
35365
35366 C...Generate the kinematics of the final particles
35367       EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
35368       GAM = EISTAR/AMN(LTARG)
35369       BET = PSTAR/EISTAR
35370       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
35371       EL  = GAM*(ELF + BET*PLF*CTSTAR)
35372       PLZ = GAM*(PLF*CTSTAR + BET*ELF)
35373       PL  = SQRT(EL**2 - AML2)
35374       PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
35375       PHI = 6.28319*PYR(0)
35376       P(4,1) = PLT*COS(PHI)
35377       P(4,2) = PLT*SIN(PHI)
35378       P(4,3) = PLZ
35379       P(4,4) = EL
35380       P(4,5) = AML
35381
35382 C...4-momentum of Delta
35383       P(5,1) = -P(4,1)
35384       P(5,2) = -P(4,2)
35385       P(5,3) = ENUU-P(4,3)
35386       P(5,4) = ENUU+AMN(LTARG)-P(4,4)
35387       P(5,5) = AMD
35388
35389 C...4-momentum  of intermediate boson
35390       P(3,5) = -Q2
35391       P(3,4) = P(1,4)-P(4,4)
35392       P(3,1) = P(1,1)-P(4,1)
35393       P(3,2) = P(1,2)-P(4,2)
35394       P(3,3) = P(1,3)-P(4,3)
35395       N=5
35396
35397       DO kw=1,5
35398         pi(1)=p(kw,1)
35399         pi(2)=p(kw,2)
35400         pi(3)=p(kw,3)
35401         CALL DT_TESTROT(Pi,Po,PHI12,3)
35402         DO ll=1,3
35403           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35404         END DO
35405         p(kw,1)=po(1)
35406         p(kw,2)=po(2)
35407         p(kw,3)=po(3)
35408       END DO
35409
35410 c********************************************
35411
35412         DO kw=1,5
35413           pi(1)=p(kw,1)
35414           pi(2)=p(kw,2)
35415           pi(3)=p(kw,3)
35416           CALL DT_TESTROT(Pi,Po,PHI11,4)
35417           DO ll=1,3
35418             IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35419           END DO
35420           p(kw,1)=po(1)
35421           p(kw,2)=po(2)
35422           p(kw,3)=po(3)
35423        END DO
35424 c********************************************
35425 C         transform back into Lab.
35426
35427       CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35428
35429 C     WRITE(6,*)' Lab fram ( fermi incl.) '
35430       N=5
35431       CALL PYEXEC
35432
35433       RETURN
35434 1001  FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5,  6G10.3)
35435       END
35436
35437 *$ CREATE DT_DSIGMA_DELTA.FOR
35438 *COPY DT_DSIGMA_DELTA
35439 *
35440 *===dsigma_delta=======================================================*
35441 *
35442       DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
35443
35444       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35445       SAVE
35446
35447 C...Reaction nu + N -> lepton + Delta
35448 C.  returns the  cross section
35449 C.  dsigma/dt
35450 C.  INPUT  LNU = 1, 2  (neutrino-antineutrino)
35451 C.         QQ = t (always negative)  GeV**2
35452 C.         S  = (c.m energy)**2      GeV**2
35453 C.  OUTPUT =  10**-38 cm+2/GeV**2
35454 C-----------------------------------------------------
35455       REAL*8 MN, MN2, MN4, MD,MD2, MD4
35456       DATA MN /0.938/
35457       DATA PI /3.1415926/
35458
35459       GF = (1.1664 * 1.97)
35460       GF2 = GF*GF
35461       MN2 = MN*MN
35462       MN4 = MN2*MN2
35463       MD2 = MD*MD
35464       MD4 = MD2*MD2
35465       AML2 = AML*AML
35466       AML4 = AML2*AML2
35467       VQ  = (MN2 - MD2 - QQ)/2.
35468       VPI = (MN2 + MD2 - QQ)/2.
35469       VK  = (S + QQ - MN2 - AML2)/2.
35470       PIK = (S - MN2)/2.
35471       QK = (AML2 - QQ)/2.
35472       PIQ = (QQ + MN2 - MD2)/2.
35473       Q = SQRT(-QQ)
35474       C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
35475       C3 = SQRT(3.)*C3V/MN
35476       C4 = -C3/MD             ! attenzione al segno
35477       C5A = 1.18/(1.-QQ/0.4225)**2
35478       C32 = C3**2
35479       C42 = C4**2
35480       C5A2 = C5A**2
35481
35482       IF (LNU .EQ. 1)  THEN
35483       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35484      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35485      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35486      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35487       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35488      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35489      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35490      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35491      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35492      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
35493      . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35494      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35495      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35496      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35497      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
35498      . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
35499      . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
35500      . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
35501      . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
35502      . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35503      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35504      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35505      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35506       ELSE
35507       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35508      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35509      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35510      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35511       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35512      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35513      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35514      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35515      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35516      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
35517      . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35518      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35519      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35520      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35521      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
35522      . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
35523      . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
35524      . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
35525      . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
35526      . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35527      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35528      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35529      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35530       ENDIF
35531       ANS1=32.*ANS2
35532       ANS=ANS1/(3.*MD2)
35533       P1CM = (S-MN2)/(2.*SQRT(S))
35534       DT_DSIGMA_DELTA  = GF2/2. * ANS/(64.*PI*S*P1CM**2)
35535
35536       RETURN
35537       END
35538
35539 *$ CREATE DT_QGAUS.FOR
35540 *COPY DT_QGAUS
35541 *
35542 *===qgaus==============================================================*
35543 *
35544       SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
35545
35546       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35547       SAVE
35548
35549       DIMENSION X(5),W(5)
35550       DATA X/.1488743389D0,.4333953941D0,
35551      & .6794095682D0,.8650633666D0,.9739065285D0
35552      */
35553       DATA W/.2955242247D0,.2692667193D0,
35554      & .2190863625D0,.1494513491D0,.0666713443D0
35555      */
35556       XM=0.5D0*(B+A)
35557       XR=0.5D0*(B-A)
35558       SS=0
35559       DO 11 J=1,5
35560         DX=XR*X(J)
35561         SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
35562      &  DT_DSQEL_Q2(LTYP,ENU,XM-DX))
35563 11    CONTINUE
35564       SS=XR*SS
35565
35566       RETURN
35567       END
35568 *$ CREATE DT_DIQBRK.FOR
35569 *COPY DT_DIQBRK
35570 *
35571 *===diqbrk=============================================================*
35572 *
35573       SUBROUTINE DT_DIQBRK
35574
35575       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35576       SAVE
35577
35578 * event history
35579
35580       PARAMETER (NMXHKK=200000)
35581
35582       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35583      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35584      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35585
35586 * extended event history
35587       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35588      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35589      &                IHIST(2,NMXHKK)
35590
35591 * event flag
35592       COMMON /DTEVNO/ NEVENT,ICASCA
35593
35594 C     IF(DT_RNDM(VV).LE.0.5D0)THEN
35595 C       CALL GSQBS1(NHKK)
35596 C       CALL GSQBS2(NHKK)
35597 C       CALL USQBS1(NHKK)
35598 C       CALL USQBS2(NHKK)
35599 C       CALL GSABS1(NHKK)
35600 C       CALL GSABS2(NHKK)
35601 C       CALL USABS1(NHKK)
35602 C       CALL USABS2(NHKK)
35603 C     ELSE
35604 C       CALL GSQBS2(NHKK)
35605 C       CALL GSQBS1(NHKK)
35606 C       CALL USQBS2(NHKK)
35607 C       CALL USQBS1(NHKK)
35608 C       CALL GSABS2(NHKK)
35609 C       CALL GSABS1(NHKK)
35610 C       CALL USABS2(NHKK)
35611 C       CALL USABS1(NHKK)
35612 C     ENDIF
35613
35614       IF(DT_RNDM(VV).LE.0.5D0) THEN
35615         CALL DT_DBREAK(1)
35616         CALL DT_DBREAK(2)
35617         CALL DT_DBREAK(3)
35618         CALL DT_DBREAK(4)
35619         CALL DT_DBREAK(5)
35620         CALL DT_DBREAK(6)
35621         CALL DT_DBREAK(7)
35622         CALL DT_DBREAK(8)
35623       ELSE
35624         CALL DT_DBREAK(2)
35625         CALL DT_DBREAK(1)
35626         CALL DT_DBREAK(4)
35627         CALL DT_DBREAK(3)
35628         CALL DT_DBREAK(6)
35629         CALL DT_DBREAK(5)
35630         CALL DT_DBREAK(8)
35631         CALL DT_DBREAK(7)
35632       ENDIF
35633
35634       RETURN
35635       END
35636
35637 *$ CREATE MUSQBS2.FOR
35638 *COPY MUSQBS2
35639 C
35640 C
35641 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
35642       SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35643      *              IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
35644 C
35645 C                  USQBS-2 diagram (split target diquark)
35646 C
35647       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35648       SAVE
35649
35650       PARAMETER ( LINP = 10 ,
35651      &            LOUT = 6 ,
35652      &            LDAT = 9 )
35653
35654 * event history
35655
35656       PARAMETER (NMXHKK=200000)
35657
35658       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35659      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35660      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35661
35662 * extended event history
35663       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35664      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35665      &                IHIST(2,NMXHKK)
35666
35667 * Lorentz-parameters of the current interaction
35668       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
35669      &                UMO,PPCM,EPROJ,PPROJ
35670
35671 * diquark-breaking mechanism
35672       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
35673
35674 C
35675       PARAMETER (NTMHKK= 300)
35676       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35677      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35678      +(4,NTMHKK)
35679 *KEEP,XSEADI.
35680       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
35681      +SSMIMQ,VVMTHR
35682 *KEEP,DPRIN.
35683       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
35684       COMMON /EVFLAG/ NUMEV
35685 C
35686 C                  USQBS-2 diagram (split target diquark)
35687 C
35688 C
35689 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
35690 C     Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
35691 C
35692 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
35693 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35694 C
35695 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35696 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35697 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35698 C
35699 C
35700 C       Put new chains into COMMON /HKKTMP/
35701 C
35702       IIGLU1=NC1T-NC1P-1
35703       IIGLU2=NC2T-NC2P-1
35704       IGCOUN=0
35705 C     WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
35706       CVQ=1.D0
35707       IREJ=0
35708       IF(IPIP.EQ.2)THEN
35709 C     IF(NUMEV.EQ.-324)THEN
35710 C     WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
35711 C    *             'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
35712 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35713 C    *              IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
35714       ENDIF
35715 C
35716 C
35717 C
35718 C     determine x-values of NC1T diquark
35719       XDIQT=PHKK(4,NC1T)*2.D0/UMO
35720       XVQP=PHKK(4,NC1P)*2.D0/UMO
35721 C
35722 C     determine x-values of sea quark pair
35723 C
35724       IPCO=1
35725       ICOU=0
35726  2234 CONTINUE
35727       ICOU=ICOU+1
35728       IF(ICOU.GE.500)THEN
35729         IREJ=1
35730         IF(ISQ.EQ.3)IREJ=3
35731         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
35732         IPCO=0
35733         RETURN
35734       ENDIF
35735       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
35736      * UMO, XDIQT,XVQP
35737       XSQ=0.D0
35738       XSAQ=0.D0
35739 **NEW
35740 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
35741       IF (IPIP.EQ.1) THEN
35742          XQMAX  = XDIQT/2.0D0
35743          XAQMAX = 2.D0*XVQP/3.0D0
35744       ELSE
35745          XQMAX  = 2.D0*XVQP/3.0D0
35746          XAQMAX = XDIQT/2.0D0
35747       ENDIF
35748       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
35749       ISAQ = 6+ISQ
35750 C     write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
35751 **
35752         IF(IPCO.GE.3)
35753      &     WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35754       IF(IREJ.GE.1)THEN
35755         IF(IPCO.GE.3)
35756      &     WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35757         IPCO=0
35758         RETURN
35759       ENDIF
35760       IF(IPIP.EQ.1)THEN
35761         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35762       ELSEIF(IPIP.EQ.2)THEN
35763         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35764       ENDIF
35765       IF(IPCO.GE.3)THEN
35766         WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
35767      &  XDIQT,XVQP,XSQ,XSAQ
35768       ENDIF
35769 C
35770 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
35771 C
35772 C     XSQ=0.D0
35773       IF(IPIP.EQ.1)THEN
35774         XDIQT=XDIQT-XSQ
35775         XVQP =XVQP -XSAQ
35776       ELSEIF(IPIP.EQ.2)THEN
35777         XDIQT=XDIQT-XSAQ
35778         XVQP =XVQP -XSQ
35779       ENDIF
35780       IF(IPCO.GE.3)
35781      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
35782 C
35783 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35784 C
35785       XVTHRO=CVQ/UMO
35786       IVTHR=0
35787  3466 CONTINUE
35788       IF(IVTHR.EQ.10)THEN
35789         IREJ=1
35790         IF(ISQ.EQ.3)IREJ=3
35791         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
35792       IPCO=0
35793         RETURN
35794       ENDIF
35795       IVTHR=IVTHR+1
35796       XVTHR=XVTHRO/(201-IVTHR)
35797       UNOPRV=UNON
35798  380  CONTINUE
35799       IF(XVTHR.GT.0.66D0*XDIQT)THEN
35800         IREJ=1
35801         IF(ISQ.EQ.3)IREJ=3
35802         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR  large',
35803      *  XVTHR
35804       IPCO=0
35805         RETURN
35806       ENDIF
35807       IF(DT_RNDM(V).LT.0.5D0)THEN
35808         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35809         XVTQII=XDIQT-XVTQI
35810       ELSE
35811         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35812         XVTQI=XDIQT-XVTQII
35813       ENDIF
35814       IF(IPCO.GE.3)THEN
35815         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
35816       ENDIF
35817 C
35818 C     Prepare 4 momenta of new chains and chain ends
35819 C
35820 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35821 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35822 C    +(4,NTMHKK)
35823 C
35824 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35825 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35826 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35827 C
35828 C     SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35829 C    *              IP1,IP21,IP22,IPP1,IPP2)
35830 C
35831       IF(IPIP.EQ.1)THEN
35832         XSQ1=XSQ
35833         XSAQ1=XSAQ
35834         ISQ1=ISQ
35835         ISAQ1=ISAQ
35836       ELSEIF(IPIP.EQ.2)THEN
35837         XSQ1=XSAQ
35838         XSAQ1=XSQ
35839         ISQ1=ISAQ
35840         ISAQ1=ISQ
35841       ENDIF
35842       IDHKT(1)   =IPP1
35843       ISTHKT(1)  =951
35844       JMOHKT(1,1)=NC2P
35845       JMOHKT(2,1)=0
35846       JDAHKT(1,1)=3+IIGLU1
35847       JDAHKT(2,1)=0
35848 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35849       PHKT(1,1)  =PHKK(1,NC2P)
35850       PHKT(2,1)  =PHKK(2,NC2P)
35851       PHKT(3,1)  =PHKK(3,NC2P)
35852       PHKT(4,1)  =PHKK(4,NC2P)
35853 C     PHKT(5,1)  =PHKK(5,NC2P)
35854       XMIST  =(PHKT(4,1)**2-
35855      * PHKT(3,1)**2-PHKT(2,1)**2-
35856      *PHKT(1,1)**2)
35857       IF(XMIST.GT.0.D0)THEN
35858       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35859      *PHKT(1,1)**2)
35860       ELSE
35861 C     WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
35862       PHKT(5,1)=0.D0
35863       ENDIF
35864       VHKT(1,1)  =VHKK(1,NC2P)
35865       VHKT(2,1)  =VHKK(2,NC2P)
35866       VHKT(3,1)  =VHKK(3,NC2P)
35867       VHKT(4,1)  =VHKK(4,NC2P)
35868       WHKT(1,1)  =WHKK(1,NC2P)
35869       WHKT(2,1)  =WHKK(2,NC2P)
35870       WHKT(3,1)  =WHKK(3,NC2P)
35871       WHKT(4,1)  =WHKK(4,NC2P)
35872 C     Add here IIGLU1 gluons to this chaina
35873       PG1=0.D0
35874       PG2=0.D0
35875       PG3=0.D0
35876       PG4=0.D0
35877       IF(IIGLU1.GE.1)THEN
35878       JJG=NC1P
35879       DO 61 IIG=2,2+IIGLU1-1
35880         KKG=JJG+IIG-1
35881         IDHKT(IIG)   =IDHKK(KKG)
35882         ISTHKT(IIG)  =921
35883         JMOHKT(1,IIG)=KKG
35884         JMOHKT(2,IIG)=0
35885         JDAHKT(1,IIG)=3+IIGLU1
35886         JDAHKT(2,IIG)=0
35887         PHKT(1,IIG)=PHKK(1,KKG)
35888         PG1=PG1+ PHKT(1,IIG)
35889         PHKT(2,IIG)=PHKK(2,KKG)
35890         PG2=PG2+ PHKT(2,IIG)
35891         PHKT(3,IIG)=PHKK(3,KKG)
35892         PG3=PG3+ PHKT(3,IIG)
35893         PHKT(4,IIG)=PHKK(4,KKG)
35894         PG4=PG4+ PHKT(4,IIG)
35895         PHKT(5,IIG)=PHKK(5,KKG)
35896         VHKT(1,IIG)  =VHKK(1,KKG)
35897         VHKT(2,IIG)  =VHKK(2,KKG)
35898         VHKT(3,IIG)  =VHKK(3,KKG)
35899         VHKT(4,IIG)  =VHKK(4,KKG)
35900         WHKT(1,IIG) =WHKK(1,KKG)
35901         WHKT(2,IIG) =WHKK(2,KKG)
35902         WHKT(3,IIG) =WHKK(3,KKG)
35903         WHKT(4,IIG) =WHKK(4,KKG)
35904    61 CONTINUE
35905       ENDIF
35906       IDHKT(2+IIGLU1)   =IP21
35907       ISTHKT(2+IIGLU1)  =952
35908       JMOHKT(1,2+IIGLU1)=NC1T
35909       JMOHKT(2,2+IIGLU1)=0
35910       JDAHKT(1,2+IIGLU1)=3+IIGLU1
35911       JDAHKT(2,2+IIGLU1)=0
35912       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
35913       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
35914       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
35915       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
35916 C     PHKT(5,2)  =PHKK(5,NC1T)
35917       XMIST  =(PHKT(4,2+IIGLU1)**2-
35918      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35919      *PHKT(1,2+IIGLU1)**2)
35920       IF(XMIST.GT.0.D0)THEN
35921       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
35922      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35923      *PHKT(1,2+IIGLU1)**2)
35924       ELSE
35925 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35926         PHKT(5,5+IIGLU1)=0.D0
35927       ENDIF
35928       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
35929       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
35930       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
35931       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
35932       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
35933       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
35934       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
35935       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
35936       IDHKT(3+IIGLU1)   =88888
35937       ISTHKT(3+IIGLU1)  =95
35938       JMOHKT(1,3+IIGLU1)=1
35939       JMOHKT(2,3+IIGLU1)=2+IIGLU1
35940       JDAHKT(1,3+IIGLU1)=0
35941       JDAHKT(2,3+IIGLU1)=0
35942       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35943       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35944       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35945       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35946       XMIST
35947      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35948      *            -PHKT(3,3+IIGLU1)**2)
35949       IF(XMIST.GT.0.D0)THEN
35950       PHKT(5,3+IIGLU1)
35951      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35952      *            -PHKT(3,3+IIGLU1)**2)
35953       ELSE
35954 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35955         PHKT(5,5+IIGLU1)=0.D0
35956       ENDIF
35957       IF(IPIP.GE.2)THEN
35958 C     IF(NUMEV.EQ.-324)THEN
35959 C     WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
35960 C    * JDAHKT(1,1),
35961 C    *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35962       DO 71 IIG=2,2+IIGLU1-1
35963 C     WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35964 C    &             JMOHKT(1,IIG),JMOHKT(2,IIG),
35965 C    * JDAHKT(1,IIG),
35966 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35967    71 CONTINUE
35968 C     WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35969 C    * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35970 C    *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35971 C     WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35972 C    * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35973 C    *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35974       ENDIF
35975       CHAMAL=CHAM1
35976       IF(IPIP.EQ.1)THEN
35977         IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
35978       ELSEIF(IPIP.EQ.2)THEN
35979         IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
35980       ENDIF
35981       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35982 C       IREJ=1
35983         IPCO=0
35984 C       RETURN
35985 C       WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
35986         GO TO 3466
35987       ENDIF
35988       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
35989       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
35990       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
35991       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
35992       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
35993       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
35994       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
35995       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
35996       IF(IPIP.EQ.1)THEN
35997         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
35998       ELSEIF(IPIP.EQ.2)THEN
35999         IDHKT(4+IIGLU1)   =ISAQ1
36000       ENDIF
36001       ISTHKT(4+IIGLU1)  =951
36002       JMOHKT(1,4+IIGLU1)=NC1P
36003       JMOHKT(2,4+IIGLU1)=0
36004       JDAHKT(1,4+IIGLU1)=6+IIGLU1
36005       JDAHKT(2,4+IIGLU1)=0
36006 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36007       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36008       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36009       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36010       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36011 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
36012       XMIST  =(PHKT(4,4+IIGLU1)**2-
36013      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36014      *PHKT(1,4+IIGLU1)**2)
36015       IF(XMIST.GT.0.D0)THEN
36016       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
36017      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36018      *PHKT(1,4+IIGLU1)**2)
36019       ELSE
36020 C     WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
36021       PHKT(5,4+IIGLU1)=0.D0
36022       ENDIF
36023       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
36024       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
36025       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
36026       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
36027       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
36028       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
36029       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
36030       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
36031       IDHKT(5+IIGLU1)   =IP22
36032       ISTHKT(5+IIGLU1)  =952
36033       JMOHKT(1,5+IIGLU1)=NC1T
36034       JMOHKT(2,5+IIGLU1)=0
36035       JDAHKT(1,5+IIGLU1)=6+IIGLU1
36036       JDAHKT(2,5+IIGLU1)=0
36037       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36038       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36039       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36040       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36041 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
36042       XMIST  =(PHKT(4,5+IIGLU1)**2-
36043      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36044      *PHKT(1,5+IIGLU1)**2)
36045       IF(XMIST.GT.0.D0)THEN
36046       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
36047      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36048      *PHKT(1,5+IIGLU1)**2)
36049       ELSE
36050 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36051         PHKT(5,5+IIGLU1)=0.D0
36052       ENDIF
36053       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
36054       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
36055       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
36056       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
36057       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
36058       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
36059       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
36060       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
36061       IDHKT(6+IIGLU1)   =88888
36062       ISTHKT(6+IIGLU1)  =95
36063       JMOHKT(1,6+IIGLU1)=4+IIGLU1
36064       JMOHKT(2,6+IIGLU1)=5+IIGLU1
36065       JDAHKT(1,6+IIGLU1)=0
36066       JDAHKT(2,6+IIGLU1)=0
36067       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36068       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36069       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36070       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36071       XMIST
36072      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36073      *            -PHKT(3,6+IIGLU1)**2)
36074       IF(XMIST.GT.0.D0)THEN
36075       PHKT(5,6+IIGLU1)
36076      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36077      *            -PHKT(3,6+IIGLU1)**2)
36078       ELSE
36079 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36080         PHKT(5,5+IIGLU1)=0.D0
36081       ENDIF
36082 C     IF(IPIP.GE.2)THEN
36083 C     IF(NUMEV.EQ.-324)THEN
36084 C     WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36085 C    * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36086 C    *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36087 C     WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36088 C    * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36089 C    *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36090 C     WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36091 C    * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36092 C    *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36093 C     ENDIF
36094       CHAMAL=CHAM1
36095       IF(IPIP.EQ.1)THEN
36096         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36097       ELSEIF(IPIP.EQ.2)THEN
36098         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36099       ENDIF
36100       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36101 C       IREJ=1
36102         IPCO=0
36103 C       RETURN
36104 C       WRITE(6,*)' MUSQBS1 jump back from chain 6',
36105 C    *  CHAMAL,PHKT(5,6+IIGLU1)
36106         GO TO 3466
36107       ENDIF
36108       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
36109       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
36110       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
36111       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
36112       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
36113       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
36114       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
36115       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
36116 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
36117       IDHKT(7+IIGLU1)   =IP1
36118       ISTHKT(7+IIGLU1)  =951
36119       JMOHKT(1,7+IIGLU1)=NC1P
36120       JMOHKT(2,7+IIGLU1)=0
36121 **NEW
36122 C     JDAHKT(1,7+IIGLU1)=9+IIGLU1
36123       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36124 **
36125       JDAHKT(2,7+IIGLU1)=0
36126       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36127       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36128       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36129       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36130 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
36131       XMIST  =(PHKT(4,7+IIGLU1)**2-
36132      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36133      *PHKT(1,7+IIGLU1)**2)
36134       IF(XMIST.GT.0.D0)THEN
36135       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
36136      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36137      *PHKT(1,7+IIGLU1)**2)
36138       ELSE
36139 C     WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
36140       PHKT(5,7+IIGLU1)=0.D0
36141       ENDIF
36142       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
36143       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
36144       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
36145       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
36146       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
36147       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
36148       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
36149       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
36150 C     Insert here the IIGLU2 gluons
36151       PG1=0.D0
36152       PG2=0.D0
36153       PG3=0.D0
36154       PG4=0.D0
36155       IF(IIGLU2.GE.1)THEN
36156       JJG=NC2P
36157       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36158         KKG=JJG+IIG-7-IIGLU1
36159         IDHKT(IIG)   =IDHKK(KKG)
36160         ISTHKT(IIG)  =921
36161         JMOHKT(1,IIG)=KKG
36162         JMOHKT(2,IIG)=0
36163         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36164         JDAHKT(2,IIG)=0
36165         PHKT(1,IIG)=PHKK(1,KKG)
36166         PG1=PG1+ PHKT(1,IIG)
36167         PHKT(2,IIG)=PHKK(2,KKG)
36168         PG2=PG2+ PHKT(2,IIG)
36169         PHKT(3,IIG)=PHKK(3,KKG)
36170         PG3=PG3+ PHKT(3,IIG)
36171         PHKT(4,IIG)=PHKK(4,KKG)
36172         PG4=PG4+ PHKT(4,IIG)
36173         PHKT(5,IIG)=PHKK(5,KKG)
36174         VHKT(1,IIG)  =VHKK(1,KKG)
36175         VHKT(2,IIG)  =VHKK(2,KKG)
36176         VHKT(3,IIG)  =VHKK(3,KKG)
36177         VHKT(4,IIG)  =VHKK(4,KKG)
36178         WHKT(1,IIG)  =WHKK(1,KKG)
36179         WHKT(2,IIG) =WHKK(2,KKG)
36180         WHKT(3,IIG) =WHKK(3,KKG)
36181         WHKT(4,IIG) =WHKK(4,KKG)
36182    81 CONTINUE
36183       ENDIF
36184       IF(IPIP.EQ.1)THEN
36185         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
36186         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36187         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36188         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36189       ELSEIF(IPIP.EQ.2)THEN
36190         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-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       ENDIF
36195       ISTHKT(8+IIGLU1+IIGLU2)  =952
36196       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36197       JMOHKT(2,8+IIGLU1+IIGLU2)=0
36198       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36199       JDAHKT(2,8+IIGLU1+IIGLU2)=0
36200       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC2T)+
36201      * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36202       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC2T)+
36203      * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36204       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC2T)+
36205      * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36206       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC2T)+
36207      * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36208 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36209 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36210       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36211 C       IREJ=1
36212 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36213 C    *  ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
36214         IPCO=0
36215 C       RETURN
36216         GO TO 3466
36217       ENDIF
36218 C     PHKT(5,8)  =PHKK(5,NC2T)
36219       XMIST  =(PHKT(4,8+IIGLU1+IIGLU2)**2-
36220      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36221      *PHKT(1,8+IIGLU1+IIGLU2)**2)
36222       IF(XMIST.GT.0.D0)THEN
36223       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36224      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36225      *PHKT(1,8+IIGLU1+IIGLU2)**2)
36226       ELSE
36227 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36228         PHKT(5,5+IIGLU1)=0.D0
36229       ENDIF
36230       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
36231       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
36232       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
36233       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
36234       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
36235       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
36236       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
36237       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
36238       IDHKT(9+IIGLU1+IIGLU2)   =88888
36239       ISTHKT(9+IIGLU1+IIGLU2)  =95
36240       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36241       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36242       JDAHKT(1,9+IIGLU1+IIGLU2)=0
36243       JDAHKT(2,9+IIGLU1+IIGLU2)=0
36244 **NEW
36245 C     PHKT(1,9+IIGLU1+IIGLU2)
36246 C    * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36247 C     PHKT(2,9+IIGLU1+IIGLU2)
36248 C    * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36249 C     PHKT(3,9+IIGLU1+IIGLU2)
36250 C    * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36251 C     PHKT(4,9+IIGLU1+IIGLU2)
36252 C    * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36253       PHKT(1,9+IIGLU1+IIGLU2)
36254      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36255       PHKT(2,9+IIGLU1+IIGLU2)
36256      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36257       PHKT(3,9+IIGLU1+IIGLU2)
36258      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36259       PHKT(4,9+IIGLU1+IIGLU2)
36260      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36261 **
36262       XMIST
36263      * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36264      * -PHKT(2,9+IIGLU1+IIGLU2)**2
36265      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
36266       IF(XMIST.GT.0.D0)THEN
36267       PHKT(5,9+IIGLU1+IIGLU2)
36268      * =SQRT(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       ELSE
36272 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36273         PHKT(5,5+IIGLU1)=0.D0
36274       ENDIF
36275       IF(IPIP.GE.2)THEN
36276 C     IF(NUMEV.EQ.-324)THEN
36277 C     WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36278 C    * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36279 C    *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36280 C     DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36281 C     WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
36282 C    * JDAHKT(1,IIG),
36283 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36284 C  91 CONTINUE
36285 C     WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36286 C    * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36287 C    *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36288 C    *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36289 C     WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36290 C    * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36291 C    *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36292 C    *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36293       ENDIF
36294       CHAMAL=CHAB1
36295       IF(IPIP.EQ.1)THEN
36296         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36297       ELSEIF(IPIP.EQ.2)THEN
36298         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36299       ENDIF
36300       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36301 C       IREJ=1
36302         IPCO=0
36303 C       RETURN
36304 C       WRITE(6,*)' MUSQBS1 jump back from chain 9',
36305 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
36306         GO TO 3466
36307       ENDIF
36308       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
36309       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
36310       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
36311       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
36312       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
36313       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
36314       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
36315       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
36316 C
36317       IPCO=0
36318       IGCOUN=9+IIGLU1+IIGLU2
36319        RETURN
36320        END
36321
36322 *$ CREATE MGSQBS2.FOR
36323 *COPY MGSQBS2
36324 C
36325 C
36326 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36327       SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36328      *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
36329 C
36330 C                  GSQBS-2 diagram (split target diquark)
36331 C
36332       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36333       SAVE
36334
36335       PARAMETER ( LINP = 10 ,
36336      &            LOUT = 6 ,
36337      &            LDAT = 9 )
36338
36339 * event history
36340
36341       PARAMETER (NMXHKK=200000)
36342
36343       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36344      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36345      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36346
36347 * extended event history
36348       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36349      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36350      &                IHIST(2,NMXHKK)
36351
36352 * Lorentz-parameters of the current interaction
36353       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36354      &                UMO,PPCM,EPROJ,PPROJ
36355
36356 * diquark-breaking mechanism
36357       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36358
36359 C
36360       PARAMETER (NTMHKK= 300)
36361       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36362      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36363      +(4,NTMHKK)
36364
36365 *KEEP,XSEADI.
36366       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36367      +SSMIMQ,VVMTHR
36368 *KEEP,DPRIN.
36369       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36370 C
36371 C                  GSQBS-2 diagram (split target diquark)
36372 C
36373 C
36374 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
36375 C     Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
36376 C
36377 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
36378 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36379 C
36380 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36381 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36382 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36383 C
36384 C
36385 C
36386 C       Put new chains into COMMON /HKKTMP/
36387 C
36388       IIGLU1=NC1T-NC1P-1
36389       IIGLU2=NC2T-NC2P-1
36390       IGCOUN=0
36391 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36392       CVQ=1.D0
36393       IREJ=0
36394 C     IF(IPIP.EQ.2)THEN
36395 C     WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
36396 C    *             'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
36397 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36398 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
36399 C     ENDIF
36400 C
36401 C
36402 C
36403 C     determine x-values of NC1T diquark
36404       XDIQT=PHKK(4,NC1T)*2.D0/UMO
36405       XVQP=PHKK(4,NC1P)*2.D0/UMO
36406 C
36407 C     determine x-values of sea quark pair
36408 C
36409       IPCO=1
36410       ICOU=0
36411  2234 CONTINUE
36412       ICOU=ICOU+1
36413       IF(ICOU.GE.500)THEN
36414         IREJ=1
36415         IF(ISQ.EQ.3)IREJ=3
36416         IF(IPCO.GE.3)
36417      &     WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
36418         IPCO=0
36419         RETURN
36420       ENDIF
36421       IF(IPCO.GE.3)
36422      &     WRITE(LOUT,*)'MGSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
36423      * UMO, XDIQT,XVQP
36424       XSQ=0.D0
36425       XSAQ=0.D0
36426 **NEW
36427 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
36428       IF (IPIP.EQ.1) THEN
36429          XQMAX  = XDIQT/2.0D0
36430          XAQMAX = 2.D0*XVQP/3.0D0
36431       ELSE
36432          XQMAX  = 2.D0*XVQP/3.0D0
36433          XAQMAX = XDIQT/2.0D0
36434       ENDIF
36435       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
36436       ISAQ = 6+ISQ
36437 C     write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
36438 **
36439         IF(IPCO.GE.3)
36440      &     WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36441       IF(IREJ.GE.1)THEN
36442         IF(IPCO.GE.3)
36443      &     WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36444         IPCO=0
36445         RETURN
36446       ENDIF
36447       IF(IPIP.EQ.1)THEN
36448         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36449       ELSEIF(IPIP.EQ.2)THEN
36450         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36451       ENDIF
36452       IF(IPCO.GE.3)THEN
36453         WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
36454      &  XDIQT,XVQP,XSQ,XSAQ
36455       ENDIF
36456 C
36457 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
36458 C
36459 C     XSQ=0.D0
36460       IF(IPIP.EQ.1)THEN
36461         XDIQT=XDIQT-XSQ
36462         XVQP =XVQP -XSAQ
36463       ELSEIF(IPIP.EQ.2)THEN
36464         XDIQT=XDIQT-XSAQ
36465         XVQP =XVQP -XSQ
36466       ENDIF
36467       IF(IPCO.GE.3)
36468      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
36469 C
36470 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36471 C
36472       XVTHRO=CVQ/UMO
36473       IVTHR=0
36474  3466 CONTINUE
36475       IF(IVTHR.EQ.10)THEN
36476         IREJ=1
36477         IF(ISQ.EQ.3)IREJ=3
36478         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
36479         IPCO=0
36480         RETURN
36481       ENDIF
36482       IVTHR=IVTHR+1
36483       XVTHR=XVTHRO/(201-IVTHR)
36484       UNOPRV=UNON
36485  380  CONTINUE
36486       IF(XVTHR.GT.0.66D0*XDIQT)THEN
36487         IREJ=1
36488         IF(ISQ.EQ.3)IREJ=3
36489         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR  large',
36490      *  XVTHR
36491         IPCO=0
36492         RETURN
36493       ENDIF
36494       IF(DT_RNDM(V).LT.0.5D0)THEN
36495         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36496         XVTQII=XDIQT-XVTQI
36497       ELSE
36498         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36499         XVTQI=XDIQT-XVTQII
36500       ENDIF
36501       IF(IPCO.GE.3)THEN
36502         WRITE(LOUT,'(A,2E12.4)')'  MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
36503       ENDIF
36504 C
36505 C     Prepare 4 momenta of new chains and chain ends
36506 C
36507 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36508 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36509 C    +(4,NTMHKK)
36510 C
36511 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36512 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36513 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36514 C
36515 C     SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36516 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
36517 C
36518       IF(IPIP.EQ.1)THEN
36519         XSQ1=XSQ
36520         XSAQ1=XSAQ
36521         ISQ1=ISQ
36522         ISAQ1=ISAQ
36523       ELSEIF(IPIP.EQ.2)THEN
36524         XSQ1=XSAQ
36525         XSAQ1=XSQ
36526         ISQ1=ISAQ
36527         ISAQ1=ISQ
36528       ENDIF
36529       KK11=IP21
36530 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36531       KK21=IPP11
36532       KK22=IPP12
36533       XGIVE=0.D0
36534       IF(IPIP.EQ.1)THEN
36535         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
36536       ELSEIF(IPIP.EQ.2)THEN
36537         IDHKT(4+IIGLU1)   =ISAQ1
36538       ENDIF
36539       ISTHKT(4+IIGLU1)  =961
36540       JMOHKT(1,4+IIGLU1)=NC1P
36541       JMOHKT(2,4+IIGLU1)=0
36542       JDAHKT(1,4+IIGLU1)=6+IIGLU1
36543       JDAHKT(2,4+IIGLU1)=0
36544 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36545       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36546       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36547       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36548       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36549 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
36550       XXMIST=(PHKT(4,4+IIGLU1)**2-
36551      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36552      *PHKT(1,4+IIGLU1)**2)
36553       IF(XXMIST.GT.0.D0)THEN
36554         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
36555       ELSE
36556         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36557         XXMIST=ABS(XXMIST)
36558         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
36559       ENDIF
36560       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
36561       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
36562       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
36563       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
36564       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
36565       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
36566       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
36567       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
36568       IDHKT(5+IIGLU1)   =IP22
36569       ISTHKT(5+IIGLU1)  =962
36570       JMOHKT(1,5+IIGLU1)=NC1T
36571       JMOHKT(2,5+IIGLU1)=0
36572       JDAHKT(1,5+IIGLU1)=6+IIGLU1
36573       JDAHKT(2,5+IIGLU1)=0
36574       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36575       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36576       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36577       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36578 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
36579       XXMIST=(PHKT(4,5+IIGLU1)**2-
36580      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36581      *PHKT(1,5+IIGLU1)**2)
36582       IF(XXMIST.GT.0.D0)THEN
36583         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
36584       ELSE
36585         WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
36586         XXMIST=ABS(XXMIST)
36587         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
36588       ENDIF
36589       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
36590       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
36591       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
36592       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
36593       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
36594       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
36595       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
36596       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
36597       IDHKT(6+IIGLU1)   =88888
36598       ISTHKT(6+IIGLU1)  =96
36599       JMOHKT(1,6+IIGLU1)=4+IIGLU1
36600       JMOHKT(2,6+IIGLU1)=5+IIGLU1
36601       JDAHKT(1,6+IIGLU1)=0
36602       JDAHKT(2,6+IIGLU1)=0
36603       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36604       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36605       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36606       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36607       PHKT(5,6+IIGLU1)
36608      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36609      *            -PHKT(3,6+IIGLU1)**2)
36610       CHAMAL=CHAM1
36611       IF(IPIP.EQ.1)THEN
36612         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36613       ELSEIF(IPIP.EQ.2)THEN
36614         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36615       ENDIF
36616 C---------------------------------------------------
36617       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36618         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
36619 C                    we drop chain 6 and give the energy to chain 3
36620           IDHKT(6+IIGLU1)=22888
36621           XGIVE=1.D0
36622 C         WRITE(6,*)' drop chain 6 xgive=1'
36623           GO TO 7788
36624         ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
36625 C                    we drop chain 6 and give the energy to chain 3
36626 C                    and change KK11 to IDHKT(5)
36627           IDHKT(6+IIGLU1)=22888
36628           XGIVE=1.D0
36629 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
36630           KK11=IDHKT(5+IIGLU1)
36631           GO TO 7788
36632         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
36633 C                    we drop chain 6 and give the energy to chain 3
36634 C                    and change KK21 to IDHKT(5+IIGLU1)
36635 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36636           IDHKT(6+IIGLU1)=22888
36637           XGIVE=1.D0
36638 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
36639           KK21=IDHKT(5+IIGLU1)
36640           GO TO 7788
36641         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
36642 C                    we drop chain 6 and give the energy to chain 3
36643 C                    and change KK22 to IDHKT(5)
36644 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36645           IDHKT(6+IIGLU1)=22888
36646           XGIVE=1.D0
36647 C          WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
36648           KK22=IDHKT(5+IIGLU1)
36649           GO TO 7788
36650         ENDIF
36651 C       IREJ=1
36652         IPCO=0
36653 C       RETURN
36654         GO TO 3466
36655       ENDIF
36656  7788 CONTINUE
36657 C---------------------------------------------------
36658       IF(IPIP.GE.3)THEN
36659       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36660      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36661      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36662       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36663      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36664      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36665       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36666      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36667      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36668       ENDIF
36669       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
36670       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
36671       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
36672       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
36673       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
36674       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
36675       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
36676       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
36677 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36678       IF(IPIP.EQ.1)THEN
36679         IDHKT(1)   =1000*KK21+100*KK22+3
36680         IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
36681         IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
36682         IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
36683       ELSEIF(IPIP.EQ.2)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       ENDIF
36689       ISTHKT(1)  =961
36690       JMOHKT(1,1)=NC2P
36691       JMOHKT(2,1)=0
36692       JDAHKT(1,1)=3+IIGLU1
36693       JDAHKT(2,1)=0
36694 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36695       PHKT(1,1)  =PHKK(1,NC2P)
36696      *+XGIVE*PHKT(1,4+IIGLU1)
36697       PHKT(2,1)  =PHKK(2,NC2P)
36698      *+XGIVE*PHKT(2,4+IIGLU1)
36699       PHKT(3,1)  =PHKK(3,NC2P)
36700      *+XGIVE*PHKT(3,4+IIGLU1)
36701       PHKT(4,1)  =PHKK(4,NC2P)
36702      *+XGIVE*PHKT(4,4+IIGLU1)
36703 C     PHKT(5,1)  =PHKK(5,NC2P)
36704       XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36705      *PHKT(1,1)**2
36706       IF(XXMIST.GT.0.D0)THEN
36707         PHKT(5,1)  =SQRT(XXMIST)
36708       ELSE
36709         WRITE(LOUT,*)'MGSQBS2',XXMIST
36710         XXMIST=ABS(XXMIST)
36711         PHKT(5,1)  =SQRT(XXMIST)
36712       ENDIF
36713       VHKT(1,1)  =VHKK(1,NC2P)
36714       VHKT(2,1)  =VHKK(2,NC2P)
36715       VHKT(3,1)  =VHKK(3,NC2P)
36716       VHKT(4,1)  =VHKK(4,NC2P)
36717       WHKT(1,1)  =WHKK(1,NC2P)
36718       WHKT(2,1)  =WHKK(2,NC2P)
36719       WHKT(3,1)  =WHKK(3,NC2P)
36720       WHKT(4,1)  =WHKK(4,NC2P)
36721 C     Add here IIGLU1 gluons to this chaina
36722       PG1=0.D0
36723       PG2=0.D0
36724       PG3=0.D0
36725       PG4=0.D0
36726       IF(IIGLU1.GE.1)THEN
36727       JJG=NC1P
36728       DO 61 IIG=2,2+IIGLU1-1
36729         KKG=JJG+IIG-1
36730         IDHKT(IIG)   =IDHKK(KKG)
36731         ISTHKT(IIG)  =921
36732         JMOHKT(1,IIG)=KKG
36733         JMOHKT(2,IIG)=0
36734         JDAHKT(1,IIG)=3+IIGLU1
36735         JDAHKT(2,IIG)=0
36736         PHKT(1,IIG)=PHKK(1,KKG)
36737         PG1=PG1+ PHKT(1,IIG)
36738         PHKT(2,IIG)=PHKK(2,KKG)
36739         PG2=PG2+ PHKT(2,IIG)
36740         PHKT(3,IIG)=PHKK(3,KKG)
36741         PG3=PG3+ PHKT(3,IIG)
36742         PHKT(4,IIG)=PHKK(4,KKG)
36743         PG4=PG4+ PHKT(4,IIG)
36744         PHKT(5,IIG)=PHKK(5,KKG)
36745         VHKT(1,IIG)  =VHKK(1,KKG)
36746         VHKT(2,IIG)  =VHKK(2,KKG)
36747         VHKT(3,IIG)  =VHKK(3,KKG)
36748         VHKT(4,IIG)  =VHKK(4,KKG)
36749         WHKT(1,IIG)  =WHKK(1,KKG)
36750         WHKT(2,IIG)  =WHKK(2,KKG)
36751         WHKT(3,IIG)  =WHKK(3,KKG)
36752         WHKT(4,IIG)  =WHKK(4,KKG)
36753    61 CONTINUE
36754       ENDIF
36755 C     IDHKT(2)   =IP21
36756       IDHKT(2+IIGLU1)   =KK11
36757       ISTHKT(2+IIGLU1)  =962
36758       JMOHKT(1,2+IIGLU1)=NC1T
36759       JMOHKT(2,2+IIGLU1)=0
36760       JDAHKT(1,2+IIGLU1)=3+IIGLU1
36761       JDAHKT(2,2+IIGLU1)=0
36762       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
36763 C    * +0.5D0*PHKK(1,NC2T)
36764      *+XGIVE*PHKT(1,5+IIGLU1)
36765       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
36766 C    *+0.5D0*PHKK(2,NC2T)
36767      *+XGIVE*PHKT(2,5+IIGLU1)
36768       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
36769 C    *+0.5D0*PHKK(3,NC2T)
36770      *+XGIVE*PHKT(3,5+IIGLU1)
36771       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
36772 C    *+0.5D0*PHKK(4,NC2T)
36773      *+XGIVE*PHKT(4,5+IIGLU1)
36774 C     PHKT(5,2)  =PHKK(5,NC1T)
36775       XXMIST=(PHKT(4,2+IIGLU1)**2-
36776      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36777      *PHKT(1,2+IIGLU1)**2)
36778       IF(XXMIST.GT.0.D0)THEN
36779         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
36780       ELSE
36781         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36782         XXMIST=ABS(XXMIST)
36783         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
36784       ENDIF
36785       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
36786       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
36787       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
36788       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
36789       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
36790       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
36791       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
36792       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
36793       IDHKT(3+IIGLU1)   =88888
36794       ISTHKT(3+IIGLU1)  =96
36795       JMOHKT(1,3+IIGLU1)=1
36796       JMOHKT(2,3+IIGLU1)=2+IIGLU1
36797       JDAHKT(1,3+IIGLU1)=0
36798       JDAHKT(2,3+IIGLU1)=0
36799       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
36800       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
36801       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
36802       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
36803       PHKT(5,3+IIGLU1)
36804      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
36805      *            -PHKT(3,3+IIGLU1)**2)
36806       IF(IPIP.EQ.3)THEN
36807       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
36808      * JDAHKT(1,1),
36809      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
36810       DO 71 IIG=2,2+IIGLU1-1
36811       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36812      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
36813      * JDAHKT(1,IIG),
36814      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36815    71 CONTINUE
36816       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
36817      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
36818      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
36819       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
36820      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
36821      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
36822       ENDIF
36823       CHAMAL=CHAB1
36824       IF(IPIP.EQ.1)THEN
36825         IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
36826       ELSEIF(IPIP.EQ.2)THEN
36827         IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
36828       ENDIF
36829       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
36830 C       IREJ=1
36831         IPCO=0
36832 C       RETURN
36833         GO TO 3466
36834       ENDIF
36835       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
36836       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
36837       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
36838       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
36839       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
36840       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
36841       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
36842       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
36843 C     IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+1
36844       IDHKT(7+IIGLU1)   =IP1
36845       ISTHKT(7+IIGLU1)  =961
36846       JMOHKT(1,7+IIGLU1)=NC1P
36847       JMOHKT(2,7+IIGLU1)=0
36848       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36849       JDAHKT(2,7+IIGLU1)=0
36850       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36851       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36852       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36853       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36854 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
36855       XXMIST=(PHKT(4,7+IIGLU1)**2-
36856      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36857      *PHKT(1,7+IIGLU1)**2)
36858       IF(XXMIST.GT.0.D0)THEN
36859         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
36860       ELSE
36861         WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
36862         XXMIST=ABS(XXMIST)
36863         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
36864       ENDIF
36865       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
36866       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
36867       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
36868       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
36869       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
36870       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
36871       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
36872       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
36873 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
36874 C     Insert here the IIGLU2 gluons
36875       PG1=0.D0
36876       PG2=0.D0
36877       PG3=0.D0
36878       PG4=0.D0
36879       IF(IIGLU2.GE.1)THEN
36880       JJG=NC2P
36881       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36882         KKG=JJG+IIG-7-IIGLU1
36883         IDHKT(IIG)   =IDHKK(KKG)
36884         ISTHKT(IIG)  =921
36885         JMOHKT(1,IIG)=KKG
36886         JMOHKT(2,IIG)=0
36887         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36888         JDAHKT(2,IIG)=0
36889         PHKT(1,IIG)=PHKK(1,KKG)
36890         PG1=PG1+ PHKT(1,IIG)
36891         PHKT(2,IIG)=PHKK(2,KKG)
36892         PG2=PG2+ PHKT(2,IIG)
36893         PHKT(3,IIG)=PHKK(3,KKG)
36894         PG3=PG3+ PHKT(3,IIG)
36895         PHKT(4,IIG)=PHKK(4,KKG)
36896         PG4=PG4+ PHKT(4,IIG)
36897         PHKT(5,IIG)=PHKK(5,KKG)
36898         VHKT(1,IIG)  =VHKK(1,KKG)
36899         VHKT(2,IIG)  =VHKK(2,KKG)
36900         VHKT(3,IIG)  =VHKK(3,KKG)
36901         VHKT(4,IIG)  =VHKK(4,KKG)
36902         WHKT(1,IIG)  =WHKK(1,KKG)
36903         WHKT(2,IIG)  =WHKK(2,KKG)
36904         WHKT(3,IIG)  =WHKK(3,KKG)
36905         WHKT(4,IIG)  =WHKK(4,KKG)
36906    81 CONTINUE
36907       ENDIF
36908       IF(IPIP.EQ.1)THEN
36909         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
36910         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36911         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36912         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36913       ELSEIF(IPIP.EQ.2)THEN
36914 **NEW
36915 C       IDHKT(8)   =1000*IPP2+100*(-ISQ1+6)-3
36916         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
36917 **
36918         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36919         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36920         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36921       ENDIF
36922       ISTHKT(8+IIGLU1+IIGLU2)  =962
36923       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36924       JMOHKT(2,8+IIGLU1+IIGLU2)=0
36925       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36926       JDAHKT(2,8+IIGLU1+IIGLU2)=0
36927 C     PHKT(1,8)  =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
36928 C     PHKT(2,8)  =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
36929 C     PHKT(3,8)  =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
36930 C     PHKT(4,8)  =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
36931       PHKT(1,8+IIGLU1+IIGLU2)  =
36932      * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36933       PHKT(2,8+IIGLU1+IIGLU2)  =
36934      * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36935       PHKT(3,8+IIGLU1+IIGLU2)  =
36936      * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36937       PHKT(4,8+IIGLU1+IIGLU2)  =
36938      * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36939 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36940 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36941       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36942 C       IREJ=1
36943 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36944         IPCO=0
36945 C       RETURN
36946         GO TO 3466
36947       ENDIF
36948 C     PHKT(5,8)  =PHKK(5,NC2T)
36949       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36950      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36951      *PHKT(1,8+IIGLU1+IIGLU2)**2)
36952       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
36953       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
36954       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
36955       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
36956       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
36957       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
36958       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
36959       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
36960       IDHKT(9+IIGLU1+IIGLU2)   =88888
36961       ISTHKT(9+IIGLU1+IIGLU2)  =96
36962       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36963       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36964       JDAHKT(1,9+IIGLU1+IIGLU2)=0
36965       JDAHKT(2,9+IIGLU1+IIGLU2)=0
36966       PHKT(1,9+IIGLU1+IIGLU2)
36967      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36968       PHKT(2,9+IIGLU1+IIGLU2)
36969      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36970       PHKT(3,9+IIGLU1+IIGLU2)
36971      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36972       PHKT(4,9+IIGLU1+IIGLU2)
36973      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36974       PHKT(5,9+IIGLU1+IIGLU2)
36975      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
36976      * PHKT(2,9+IIGLU1+IIGLU2)**2
36977      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
36978       IF(IPIP.GE.3)THEN
36979       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36980      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36981      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36982       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36983       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36984      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
36985      * JDAHKT(1,IIG),
36986      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36987    91 CONTINUE
36988       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36989      * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36990      *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36991      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36992       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36993      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36994      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36995      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36996       ENDIF
36997       CHAMAL=CHAB1
36998       IF(IPIP.EQ.1)THEN
36999         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37000       ELSEIF(IPIP.EQ.2)THEN
37001         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37002       ENDIF
37003       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37004 C       IREJ=1
37005         IPCO=0
37006 C       RETURN
37007         GO TO 3466
37008       ENDIF
37009       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
37010       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
37011       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
37012       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
37013       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
37014       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
37015       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
37016       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
37017 C
37018       IPCO=0
37019       IGCOUN=9+IIGLU1+IIGLU2
37020        RETURN
37021        END
37022
37023 *$ CREATE MUSQBS1.FOR
37024 *COPY MUSQBS1
37025 C
37026 C
37027 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37028       SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37029      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
37030 C
37031 C                  USQBS-1 diagram (split projectile diquark)
37032 C
37033       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37034       SAVE
37035
37036       PARAMETER ( LINP = 10 ,
37037      &            LOUT = 6 ,
37038      &            LDAT = 9 )
37039
37040 * event history
37041
37042       PARAMETER (NMXHKK=200000)
37043
37044       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37045      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37046      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37047
37048 * extended event history
37049       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37050      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37051      &                IHIST(2,NMXHKK)
37052
37053 * Lorentz-parameters of the current interaction
37054       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37055      &                UMO,PPCM,EPROJ,PPROJ
37056
37057 * diquark-breaking mechanism
37058       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37059
37060 C
37061       PARAMETER (NTMHKK= 300)
37062       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37063      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37064      +(4,NTMHKK)
37065 *KEEP,XSEADI.
37066       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37067      +SSMIMQ,VVMTHR
37068 *KEEP,DPRIN.
37069       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37070       COMMON /EVFLAG/ NUMEV
37071 C
37072 C                  USQBS-1 diagram (split projectile diquark)
37073 C
37074 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37075 C     Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
37076 C
37077 C     Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
37078 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37079 C
37080 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37081 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37082 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37083 C
37084 C       Put new chains into COMMON /HKKTMP/
37085 C
37086       IIGLU1=NC1T-NC1P-1
37087       IIGLU2=NC2T-NC2P-1
37088       IGCOUN=0
37089 C     WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
37090       CVQ=1.D0
37091       IREJ=0
37092       IF(IPIP.EQ.3)THEN
37093 C     IF(NUMEV.EQ.-324)THEN
37094       WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37095      *             ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
37096      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37097      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
37098       ENDIF
37099 C
37100 C
37101 C
37102 C     determine x-values of NC1P diquark
37103       XDIQP=PHKK(4,NC1P)*2.D0/UMO
37104       XVQT=PHKK(4,NC1T)*2.D0/UMO
37105 C
37106 C     determine x-values of sea quark pair
37107 C
37108       IPCO=1
37109       ICOU=0
37110  2234 CONTINUE
37111       ICOU=ICOU+1
37112       IF(ICOU.GE.500)THEN
37113         IREJ=1
37114         IF(ISQ.EQ.3)IREJ=3
37115         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
37116         IPCO=0
37117         RETURN
37118       ENDIF
37119       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
37120      * UMO, XDIQP,XVQT
37121       XSQ=0.D0
37122       XSAQ=0.D0
37123 **NEW
37124 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37125       IF (IPIP.EQ.1) THEN
37126          XQMAX  = XDIQP/2.0D0
37127          XAQMAX = 2.D0*XVQT/3.0D0
37128       ELSE
37129          XQMAX  = 2.D0*XVQT/3.0D0
37130          XAQMAX = XDIQP/2.0D0
37131       ENDIF
37132       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37133       ISAQ = 6+ISQ
37134 C     write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37135 **
37136       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37137       IF(IREJ.GE.1)THEN
37138         IF(IPCO.GE.3)
37139      &     WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37140         IPCO=0
37141         RETURN
37142       ENDIF
37143       IF(IPIP.EQ.1)THEN
37144         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37145       ELSEIF(IPIP.EQ.2)THEN
37146         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37147       ENDIF
37148       IF(IPCO.GE.3)THEN
37149         WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37150      &  XDIQP,XVQT,XSQ,XSAQ
37151       ENDIF
37152 C
37153 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
37154 C
37155 C     XSQ=0.D0
37156       IF(IPIP.EQ.1)THEN
37157         XDIQP=XDIQP-XSQ
37158         XVQT =XVQT -XSAQ
37159       ELSEIF(IPIP.EQ.2)THEN
37160         XDIQP=XDIQP-XSAQ
37161         XVQT =XVQT -XSQ
37162       ENDIF
37163       IF(IPCO.GE.3)
37164      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37165 C
37166 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37167 C
37168       XVTHRO=CVQ/UMO
37169       IVTHR=0
37170  3466 CONTINUE
37171       IF(IVTHR.EQ.10)THEN
37172         IREJ=1
37173         IF(ISQ.EQ.3)IREJ=3
37174         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
37175         IPCO=0
37176         RETURN
37177       ENDIF
37178       IVTHR=IVTHR+1
37179       XVTHR=XVTHRO/(201-IVTHR)
37180       UNOPRV=UNON
37181  380  CONTINUE
37182       IF(XVTHR.GT.0.66D0*XDIQP)THEN
37183         IREJ=1
37184         IF(ISQ.EQ.3)IREJ=3
37185         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR  large',
37186      *  XVTHR
37187         IPCO=0
37188         RETURN
37189       ENDIF
37190       IF(DT_RNDM(V).LT.0.5D0)THEN
37191         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37192         XVPQII=XDIQP-XVPQI
37193       ELSE
37194         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37195         XVPQI=XDIQP-XVPQII
37196       ENDIF
37197       IF(IPCO.GE.3)THEN
37198         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
37199       ENDIF
37200 C
37201 C     Prepare 4 momenta of new chains and chain ends
37202 C
37203 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37204 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37205 C    +(4,NTMHKK)
37206 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37207 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37208 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37209       IF(IPIP.EQ.1)THEN
37210         XSQ1=XSQ
37211         XSAQ1=XSAQ
37212         ISQ1=ISQ
37213         ISAQ1=ISAQ
37214       ELSEIF(IPIP.EQ.2)THEN
37215         XSQ1=XSAQ
37216         XSAQ1=XSQ
37217         ISQ1=ISAQ
37218         ISAQ1=ISQ
37219       ENDIF
37220       IDHKT(1)   =IP11
37221       ISTHKT(1)  =931
37222       JMOHKT(1,1)=NC1P
37223       JMOHKT(2,1)=0
37224       JDAHKT(1,1)=3+IIGLU1
37225       JDAHKT(2,1)=0
37226 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37227       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
37228       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
37229       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
37230       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
37231 C     PHKT(5,1)  =PHKK(5,NC1P)
37232       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37233      *PHKT(1,1)**2)
37234       IF(XMIST.GE.0.D0)THEN
37235       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37236      *PHKT(1,1)**2)
37237       ELSE
37238 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37239        PHKT(5,1)=0.D0
37240       ENDIF
37241       VHKT(1,1)  =VHKK(1,NC1P)
37242       VHKT(2,1)  =VHKK(2,NC1P)
37243       VHKT(3,1)  =VHKK(3,NC1P)
37244       VHKT(4,1)  =VHKK(4,NC1P)
37245       WHKT(1,1)  =WHKK(1,NC1P)
37246       WHKT(2,1)  =WHKK(2,NC1P)
37247       WHKT(3,1)  =WHKK(3,NC1P)
37248       WHKT(4,1)  =WHKK(4,NC1P)
37249 C     Add here IIGLU1 gluons to this chaina
37250       PG1=0.D0
37251       PG2=0.D0
37252       PG3=0.D0
37253       PG4=0.D0
37254       IF(IIGLU1.GE.1)THEN
37255       JJG=NC1P
37256       DO 61 IIG=2,2+IIGLU1-1
37257         KKG=JJG+IIG-1
37258         IDHKT(IIG)   =IDHKK(KKG)
37259         ISTHKT(IIG)  =921
37260         JMOHKT(1,IIG)=KKG
37261         JMOHKT(2,IIG)=0
37262         JDAHKT(1,IIG)=3+IIGLU1
37263         JDAHKT(2,IIG)=0
37264         PHKT(1,IIG)=PHKK(1,KKG)
37265         PG1=PG1+ PHKT(1,IIG)
37266         PHKT(2,IIG)=PHKK(2,KKG)
37267         PG2=PG2+ PHKT(2,IIG)
37268         PHKT(3,IIG)=PHKK(3,KKG)
37269         PG3=PG3+ PHKT(3,IIG)
37270         PHKT(4,IIG)=PHKK(4,KKG)
37271         PG4=PG4+ PHKT(4,IIG)
37272         PHKT(5,IIG)=PHKK(5,KKG)
37273         VHKT(1,IIG)  =VHKK(1,KKG)
37274         VHKT(2,IIG)  =VHKK(2,KKG)
37275         VHKT(3,IIG)  =VHKK(3,KKG)
37276         VHKT(4,IIG)  =VHKK(4,KKG)
37277         WHKT(1,IIG) =WHKK(1,KKG)
37278         WHKT(2,IIG) =WHKK(2,KKG)
37279         WHKT(3,IIG) =WHKK(3,KKG)
37280         WHKT(4,IIG) =WHKK(4,KKG)
37281    61 CONTINUE
37282       ENDIF
37283       IDHKT(2+IIGLU1)   =IPP2
37284       ISTHKT(2+IIGLU1)  =932
37285       JMOHKT(1,2+IIGLU1)=NC2T
37286       JMOHKT(2,2+IIGLU1)=0
37287       JDAHKT(1,2+IIGLU1)=3+IIGLU1
37288       JDAHKT(2,2+IIGLU1)=0
37289       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
37290       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
37291       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
37292       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
37293 C     PHKT(5,2+IIGLU1)  =PHKK(5,NC2T)
37294       XMIST=(PHKT(4,2+IIGLU1)**2-
37295      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37296      *PHKT(1,2+IIGLU1)**2)
37297       IF(XMIST.GT.0.D0)THEN
37298       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
37299      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37300      *PHKT(1,2+IIGLU1)**2)
37301       ELSE
37302 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37303         PHKT(5,2+IIGLU1)=0.D0
37304       ENDIF
37305       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
37306       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
37307       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
37308       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
37309       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
37310       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
37311       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
37312       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
37313       IDHKT(3+IIGLU1)   =88888
37314       ISTHKT(3+IIGLU1)  =94
37315       JMOHKT(1,3+IIGLU1)=1
37316       JMOHKT(2,3+IIGLU1)=2+IIGLU1
37317       JDAHKT(1,3+IIGLU1)=0
37318       JDAHKT(2,3+IIGLU1)=0
37319       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37320       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37321       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37322       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37323       XMIST
37324      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37325      *            -PHKT(3,3+IIGLU1)**2)
37326       IF(XMIST.GE.0.D0)THEN
37327       PHKT(5,3+IIGLU1)
37328      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37329      *            -PHKT(3,3+IIGLU1)**2)
37330       ELSE
37331 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37332        PHKT(5,1)=0.D0
37333       ENDIF
37334       IF(IPIP.GE.3)THEN
37335 C     IF(NUMEV.EQ.-324)THEN
37336       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
37337      * JMOHKT(2,1),JDAHKT(1,1),
37338      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37339       DO 71 IIG=2,2+IIGLU1-1
37340       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37341      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
37342      * JDAHKT(1,IIG),
37343      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37344    71 CONTINUE
37345       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37346      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37347      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37348       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37349      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37350      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37351       ENDIF
37352       CHAMAL=CHAM1
37353       IF(IPIP.EQ.1)THEN
37354         IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
37355       ELSEIF(IPIP.EQ.2)THEN
37356         IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
37357       ENDIF
37358       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37359 C       IREJ=1
37360         IPCO=0
37361 C       RETURN
37362 C       WRITE(6,*)' MUSQBS1 jump back from chain 3'
37363         GO TO 3466
37364       ENDIF
37365       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
37366       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
37367       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
37368       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
37369       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
37370       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
37371       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
37372       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
37373       IDHKT(4+IIGLU1)   =IP12
37374       ISTHKT(4+IIGLU1)  =931
37375       JMOHKT(1,4+IIGLU1)=NC1P
37376       JMOHKT(2,4+IIGLU1)=0
37377       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37378       JDAHKT(2,4+IIGLU1)=0
37379 C   create  chain   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37380       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37381       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37382       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37383       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37384 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37385       XMIST  =(PHKT(4,4+IIGLU1)**2-
37386      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37387      *PHKT(1,4+IIGLU1)**2)
37388       IF(XMIST.GT.0.D0)THEN
37389       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
37390      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37391      *PHKT(1,4+IIGLU1)**2)
37392       ELSE
37393 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37394         PHKT(5,4+IIGLU1)=0.D0
37395       ENDIF
37396       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37397       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37398       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37399       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37400       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37401       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37402       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37403       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37404       IF(IPIP.EQ.1)THEN
37405         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
37406       ELSEIF(IPIP.EQ.2)THEN
37407         IDHKT(5+IIGLU1)   =ISAQ1
37408       ENDIF
37409       ISTHKT(5+IIGLU1)  =932
37410       JMOHKT(1,5+IIGLU1)=NC1T
37411       JMOHKT(2,5+IIGLU1)=0
37412       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37413       JDAHKT(2,5+IIGLU1)=0
37414       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37415       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37416       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37417       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37418 C     IF( PHKT(4,5).EQ.0.D0)THEN
37419 C       IREJ=1
37420 CIPCO=0
37421 CRETURN
37422 C     ENDIF
37423 C     PHKT(5,5)  =PHKK(5,NC1T)
37424       XMIST=(PHKT(4,5+IIGLU1)**2-
37425      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37426      *PHKT(1,5+IIGLU1)**2)
37427       IF(XMIST.GT.0.D0)THEN
37428       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
37429      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37430      *PHKT(1,5+IIGLU1)**2)
37431       ELSE
37432 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37433         PHKT(5,5+IIGLU1)=0.D0
37434       ENDIF
37435       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37436       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37437       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37438       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37439       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37440       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37441       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37442       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37443       IDHKT(6+IIGLU1)   =88888
37444       ISTHKT(6+IIGLU1)  =94
37445       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37446       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37447       JDAHKT(1,6+IIGLU1)=0
37448       JDAHKT(2,6+IIGLU1)=0
37449       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37450       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37451       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37452       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37453       XMIST
37454      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37455      *            -PHKT(3,6+IIGLU1)**2)
37456       IF(XMIST.GE.0.D0)THEN
37457       PHKT(5,6+IIGLU1)
37458      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37459      *            -PHKT(3,6+IIGLU1)**2)
37460       ELSE
37461 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37462        PHKT(5,1)=0.D0
37463       ENDIF
37464 C     IF(IPIP.EQ.3)THEN
37465       CHAMAL=CHAM1
37466       IF(IPIP.EQ.1)THEN
37467         IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37468       ELSEIF(IPIP.EQ.2)THEN
37469         IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37470       ENDIF
37471       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37472 C       IREJ=1
37473         IPCO=0
37474 C       RETURN
37475 C       WRITE(6,*)' MGSQBS1 jump back from chain 6',
37476 C    &  CHAMAL,PHKT(5,6+IIGLU1)
37477         GO TO 3466
37478       ENDIF
37479       IF(IPIP.GE.3)THEN
37480 C     IF(NUMEV.EQ.-324)THEN
37481       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37482      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37483      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37484       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37485      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37486      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37487       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37488      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37489      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37490       ENDIF
37491       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
37492       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
37493       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
37494       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
37495       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
37496       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
37497       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
37498       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
37499       IF(IPIP.EQ.1)THEN
37500         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+3
37501         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
37502         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
37503         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
37504       ELSEIF(IPIP.EQ.2)THEN
37505         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-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 C       WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
37510       ENDIF
37511       ISTHKT(7+IIGLU1)  =931
37512       JMOHKT(1,7+IIGLU1)=NC2P
37513       JMOHKT(2,7+IIGLU1)=0
37514       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37515       JDAHKT(2,7+IIGLU1)=0
37516 C    create chain     9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37517       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
37518       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
37519       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
37520       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
37521 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
37522 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
37523       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
37524 C       IREJ=1
37525 C       WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
37526         IPCO=0
37527 C       RETURN
37528         GO TO 3466
37529       ENDIF
37530 C     PHKT(5,7)  =PHKK(5,NC2P)
37531       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
37532      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37533      *PHKT(1,7+IIGLU1)**2)
37534       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
37535       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
37536       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
37537       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
37538       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
37539       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
37540       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
37541       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
37542 C     Insert here the IIGLU2 gluons
37543       PG1=0.D0
37544       PG2=0.D0
37545       PG3=0.D0
37546       PG4=0.D0
37547       IF(IIGLU2.GE.1)THEN
37548       JJG=NC2P
37549       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37550         KKG=JJG+IIG-7-IIGLU1
37551         IDHKT(IIG)   =IDHKK(KKG)
37552         ISTHKT(IIG)  =921
37553         JMOHKT(1,IIG)=KKG
37554         JMOHKT(2,IIG)=0
37555         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37556         JDAHKT(2,IIG)=0
37557         PHKT(1,IIG)=PHKK(1,KKG)
37558         PG1=PG1+ PHKT(1,IIG)
37559         PHKT(2,IIG)=PHKK(2,KKG)
37560         PG2=PG2+ PHKT(2,IIG)
37561         PHKT(3,IIG)=PHKK(3,KKG)
37562         PG3=PG3+ PHKT(3,IIG)
37563         PHKT(4,IIG)=PHKK(4,KKG)
37564         PG4=PG4+ PHKT(4,IIG)
37565         PHKT(5,IIG)=PHKK(5,KKG)
37566         VHKT(1,IIG)  =VHKK(1,KKG)
37567         VHKT(2,IIG)  =VHKK(2,KKG)
37568         VHKT(3,IIG)  =VHKK(3,KKG)
37569         VHKT(4,IIG)  =VHKK(4,KKG)
37570         WHKT(1,IIG)  =WHKK(1,KKG)
37571         WHKT(2,IIG) =WHKK(2,KKG)
37572         WHKT(3,IIG) =WHKK(3,KKG)
37573         WHKT(4,IIG) =WHKK(4,KKG)
37574    81 CONTINUE
37575       ENDIF
37576       IDHKT(8+IIGLU1+IIGLU2)   =IP2
37577       ISTHKT(8+IIGLU1+IIGLU2)  =932
37578       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
37579       JMOHKT(2,8+IIGLU1+IIGLU2)=0
37580       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37581       JDAHKT(2,8+IIGLU1+IIGLU2)=0
37582       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
37583       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
37584       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
37585       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
37586 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
37587       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
37588      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37589      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37590       IF(XMIST.GT.0.D0)THEN
37591       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
37592      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37593      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37594       ELSE
37595 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37596         PHKT(5,8+IIGLU1+IIGLU2)=0.D0
37597       ENDIF
37598       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
37599       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
37600       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
37601       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
37602       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
37603       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
37604       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
37605       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
37606       IDHKT(9+IIGLU1+IIGLU2)   =88888
37607       ISTHKT(9+IIGLU1+IIGLU2)  =94
37608       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37609       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37610       JDAHKT(1,9+IIGLU1+IIGLU2)=0
37611       JDAHKT(2,9+IIGLU1+IIGLU2)=0
37612       PHKT(1,9+IIGLU1+IIGLU2)
37613      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37614       PHKT(2,9+IIGLU1+IIGLU2)
37615      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37616       PHKT(3,9+IIGLU1+IIGLU2)
37617      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37618       PHKT(4,9+IIGLU1+IIGLU2)
37619      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37620       XMIST
37621      *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37622      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37623      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37624       IF(XMIST.GE.0.D0)THEN
37625       PHKT(5,9+IIGLU1+IIGLU2)
37626      *=SQRT(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       ELSE
37630 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37631        PHKT(5,1)=0.D0
37632       ENDIF
37633       IF(IPIP.GE.3)THEN
37634 C     IF(NUMEV.EQ.-324)THEN
37635       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37636      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37637      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37638       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37639       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37640      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
37641      * JDAHKT(1,IIG),
37642      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37643    91 CONTINUE
37644       WRITE(LOUT,*)8+IIGLU1+IIGLU2,
37645      * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
37646      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
37647      *JDAHKT(1,8+IIGLU1+IIGLU2),
37648      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37649       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37650      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37651      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37652      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37653       ENDIF
37654       CHAMAL=CHAB1
37655       IF(IPIP.EQ.1)THEN
37656         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37657       ELSEIF(IPIP.EQ.2)THEN
37658         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37659       ENDIF
37660       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37661 C       IREJ=1
37662         IPCO=0
37663 C       RETURN
37664 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
37665 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37666         GO TO 3466
37667       ENDIF
37668       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
37669       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
37670       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
37671       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
37672       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
37673       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
37674       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
37675       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
37676 C
37677       IPCO=0
37678       IGCOUN=9+IIGLU1+IIGLU2
37679        RETURN
37680        END
37681
37682 *$ CREATE MGSQBS1.FOR
37683 *COPY MGSQBS1
37684 C
37685 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37686       SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37687      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
37688 C
37689 C                  GSQBS-1 diagram (split projectile diquark)
37690 C
37691       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37692       SAVE
37693
37694       PARAMETER ( LINP = 10 ,
37695      &            LOUT = 6 ,
37696      &            LDAT = 9 )
37697
37698 * event history
37699
37700       PARAMETER (NMXHKK=200000)
37701
37702       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37703      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37704      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37705
37706 * extended event history
37707       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37708      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37709      &                IHIST(2,NMXHKK)
37710
37711 * Lorentz-parameters of the current interaction
37712       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37713      &                UMO,PPCM,EPROJ,PPROJ
37714
37715 * diquark-breaking mechanism
37716       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37717
37718 C
37719       PARAMETER (NTMHKK= 300)
37720       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37721      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37722      +(4,NTMHKK)
37723 *KEEP,XSEADI.
37724       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37725      +SSMIMQ,VVMTHR
37726 *KEEP,DPRIN.
37727       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37728 C
37729 C                  GSQBS-1 diagram (split projectile diquark)
37730 C
37731 C
37732 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37733 C     Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
37734 C
37735 C     Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
37736 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37737 C
37738 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37739 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37740 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37741 C
37742 C       Put new chains into COMMON /HKKTMP/
37743 C
37744       IIGLU1=NC1T-NC1P-1
37745       IIGLU2=NC2T-NC2P-1
37746       IGCOUN=0
37747 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37748       CVQ=1.D0
37749       NNNC1=IDHKK(NC1)/1000
37750       MMMC1=IDHKK(NC1)-NNNC1*1000
37751       KKKC1=ISTHKK(NC1)
37752       NNNC2=IDHKK(NC2)/1000
37753       MMMC2=IDHKK(NC2)-NNNC2*1000
37754       KKKC2=ISTHKK(NC2)
37755       IREJ=0
37756       IF(IPIP.EQ.3)THEN
37757       WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37758      *             ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
37759      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37760      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
37761       ENDIF
37762 C
37763 C
37764 C
37765 C     determine x-values of NC1P diquark
37766       XDIQP=PHKK(4,NC1P)*2.D0/UMO
37767       XVQT=PHKK(4,NC1T)*2.D0/UMO
37768 C
37769 C     determine x-values of sea quark pair
37770 C
37771       IPCO=1
37772       ICOU=0
37773  2234 CONTINUE
37774       ICOU=ICOU+1
37775       IF(ICOU.GE.500)THEN
37776         IREJ=1
37777         IF(ISQ.EQ.3)IREJ=3
37778         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
37779       IPCO=0
37780         RETURN
37781       ENDIF
37782       IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
37783      * UMO, XDIQP,XVQT
37784       XSQ=0.D0
37785       XSAQ=0.D0
37786 **NEW
37787 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37788       IF (IPIP.EQ.1) THEN
37789          XQMAX  = XDIQP/2.0D0
37790          XAQMAX = 2.D0*XVQT/3.0D0
37791       ELSE
37792          XQMAX  = 2.D0*XVQT/3.0D0
37793          XAQMAX = XDIQP/2.0D0
37794       ENDIF
37795       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37796       ISAQ = 6+ISQ
37797 C     write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37798 **
37799         IF(IPCO.GE.3)
37800      &     WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37801       IF(IREJ.GE.1)THEN
37802         IF(IPCO.GE.3)
37803      &     WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37804       IPCO=0
37805         RETURN
37806       ENDIF
37807       IF(IPIP.EQ.1)THEN
37808         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37809       ELSEIF(IPIP.EQ.2)THEN
37810         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37811       ENDIF
37812       IF(IPCO.GE.3)THEN
37813         WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37814      &  XDIQP,XVQT,XSQ,XSAQ
37815       ENDIF
37816 C
37817 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
37818 C
37819 C     XSQ=0.D0
37820       IF(IPIP.EQ.1)THEN
37821         XDIQP=XDIQP-XSQ
37822 **NEW
37823 C       IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
37824 **
37825         XVQT =XVQT -XSAQ
37826       ELSEIF(IPIP.EQ.2)THEN
37827         XDIQP=XDIQP-XSAQ
37828         XVQT =XVQT -XSQ
37829       ENDIF
37830       IF(IPCO.GE.3)
37831      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37832 C
37833 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37834 C
37835       XVTHRO=CVQ/UMO
37836       IVTHR=0
37837  3466 CONTINUE
37838       IF(IVTHR.EQ.10)THEN
37839         IREJ=1
37840         IF(ISQ.EQ.3)IREJ=3
37841         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
37842       IPCO=0
37843         RETURN
37844       ENDIF
37845       IVTHR=IVTHR+1
37846       XVTHR=XVTHRO/(201-IVTHR)
37847       UNOPRV=UNON
37848  380  CONTINUE
37849       IF(XVTHR.GT.0.66D0*XDIQP)THEN
37850         IREJ=1
37851         IF(ISQ.EQ.3)IREJ=3
37852         IF(IPCO.GE.3)
37853      &     WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR  large',
37854      *  XVTHR
37855       IPCO=0
37856         RETURN
37857       ENDIF
37858       IF(DT_RNDM(V).LT.0.5D0)THEN
37859         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37860         XVPQII=XDIQP-XVPQI
37861       ELSE
37862         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37863         XVPQI=XDIQP-XVPQII
37864       ENDIF
37865       IF(IPCO.GE.3)THEN
37866         WRITE(LOUT,'(A,4E12.4)')'  MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
37867      &  XVTHR,XDIQP,XVPQI,XVPQII
37868       ENDIF
37869 C
37870 C     Prepare 4 momenta of new chains and chain ends
37871 C
37872 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37873 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37874 C    +(4,NTMHKK)
37875 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37876 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37877 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37878       IF(IPIP.EQ.1)THEN
37879         XSQ1=XSQ
37880         XSAQ1=XSAQ
37881         ISQ1=ISQ
37882         ISAQ1=ISAQ
37883       ELSEIF(IPIP.EQ.2)THEN
37884         XSQ1=XSAQ
37885         XSAQ1=XSQ
37886         ISQ1=ISAQ
37887         ISAQ1=ISQ
37888       ENDIF
37889       KK11=IP11
37890 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
37891       KK21= IPP21
37892       KK22= IPP22
37893       XGIVE=0.D0
37894       IDHKT(4+IIGLU1)   =IP12
37895       ISTHKT(4+IIGLU1)  =921
37896       JMOHKT(1,4+IIGLU1)=NC1P
37897       JMOHKT(2,4+IIGLU1)=0
37898       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37899       JDAHKT(2,4+IIGLU1)=0
37900 **NEW
37901       IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
37902      &    (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
37903 **
37904       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37905       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37906       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37907       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37908 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37909       XXMIST=(PHKT(4,4+IIGLU1)**2-
37910      *              PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37911      *              PHKT(1,4+IIGLU1)**2)
37912       IF(XXMIST.GT.0.D0)THEN
37913         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37914       ELSE
37915         WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
37916         XXMIST=ABS(XXMIST)
37917         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37918       ENDIF
37919       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37920       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37921       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37922       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37923       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37924       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37925       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37926       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37927       IF(IPIP.EQ.1)THEN
37928         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
37929       ELSEIF(IPIP.EQ.2)THEN
37930         IDHKT(5+IIGLU1)   =ISAQ1
37931       ENDIF
37932       ISTHKT(5+IIGLU1)  =922
37933       JMOHKT(1,5+IIGLU1)=NC1T
37934       JMOHKT(2,5+IIGLU1)=0
37935       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37936       JDAHKT(2,5+IIGLU1)=0
37937 **NEW
37938       IF ((XSAQ1.LT.0.0D0).OR.(XVQT  .LT.0.0D0))
37939      &    WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
37940 **
37941       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37942       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37943       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37944       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37945 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
37946       XMIST=(PHKT(4,5+IIGLU1)**2-
37947      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37948      *PHKT(1,5+IIGLU1)**2)
37949       IF(XMIST.GT.0.D0)THEN
37950       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
37951      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37952      *PHKT(1,5+IIGLU1)**2)
37953       ELSE
37954 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37955         PHKT(5,5+IIGLU1)=0.D0
37956       ENDIF
37957       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37958       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37959       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37960       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37961       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37962       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37963       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37964       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37965       IDHKT(6+IIGLU1)   =88888
37966 C     IDHKT(6)   =1000*NNNC1+MMMC1
37967       ISTHKT(6+IIGLU1)  =93
37968 C     ISTHKT(6)  =KKKC1
37969       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37970       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37971       JDAHKT(1,6+IIGLU1)=0
37972       JDAHKT(2,6+IIGLU1)=0
37973       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37974       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37975       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37976       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37977       PHKT(5,6+IIGLU1)
37978      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37979      *            -PHKT(3,6+IIGLU1)**2)
37980       CHAMAL=CHAM1
37981       IF(IPIP.EQ.1)THEN
37982         IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
37983       ELSEIF(IPIP.EQ.2)THEN
37984         IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
37985       ENDIF
37986       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37987         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37988 C                    we drop chain 6 and give the energy to chain 3
37989           IDHKT(6+IIGLU1)=33888
37990           XGIVE=1.D0
37991 C         WRITE(6,*)' drop chain 6 xgive=1'
37992           GO TO 7788
37993         ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
37994 C                    we drop chain 6 and give the energy to chain 3
37995 C                    and change KK11 to IDHKT(4)
37996           IDHKT(6+IIGLU1)=33888
37997           XGIVE=1.D0
37998 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
37999           KK11=IDHKT(4+IIGLU1)
38000           GO TO 7788
38001         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
38002 C                    we drop chain 6 and give the energy to chain 3
38003 C                    and change KK21 to IDHKT(4)
38004 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
38005           IDHKT(6+IIGLU1)=33888
38006           XGIVE=1.D0
38007 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
38008           KK21=IDHKT(4+IIGLU1)
38009           GO TO 7788
38010         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
38011 C                    we drop chain 6 and give the energy to chain 3
38012 C                    and change KK22 to IDHKT(4)
38013 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
38014           IDHKT(6+IIGLU1)=33888
38015           XGIVE=1.D0
38016 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
38017           KK22=IDHKT(4+IIGLU1)
38018           GO TO 7788
38019         ENDIF
38020 C       IREJ=1
38021         IPCO=0
38022 C       RETURN
38023 C       WRITE(6,*)' MGSQBS1 jump back from chain 6'
38024         GO TO 3466
38025       ENDIF
38026  7788 CONTINUE
38027       IF(IPIP.GE.3)THEN
38028       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38029      * JMOHKT(1,4+IIGLU1),
38030      * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38031      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38032       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38033      * JMOHKT(1,5+IIGLU1),
38034      * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38035      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38036       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38037      * JMOHKT(1,6+IIGLU1),
38038      * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38039      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38040       ENDIF
38041       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
38042       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
38043       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
38044       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
38045       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
38046       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
38047       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
38048       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
38049 C     IDHKT(1)   =IP11
38050       IDHKT(1)   =KK11
38051       ISTHKT(1)  =921
38052       JMOHKT(1,1)=NC1P
38053       JMOHKT(2,1)=0
38054       JDAHKT(1,1)=3+IIGLU1
38055       JDAHKT(2,1)=0
38056       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38057 C    * +0.5D0*PHKK(1,NC2P)
38058      *+XGIVE*PHKT(1,4+IIGLU1)
38059       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38060 C    * +0.5D0*PHKK(2,NC2P)
38061      *+XGIVE*PHKT(2,4+IIGLU1)
38062       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38063 C    * +0.5D0*PHKK(3,NC2P)
38064      *+XGIVE*PHKT(3,4+IIGLU1)
38065       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38066 C    * +0.5D0*PHKK(4,NC2P)
38067      *+XGIVE*PHKT(4,4+IIGLU1)
38068 C     PHKT(5,1)  =PHKK(5,NC1P)
38069       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38070      *PHKT(1,1)**2)
38071       IF(XMIST.GE.0.D0)THEN
38072       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38073      *PHKT(1,1)**2)
38074       ELSE
38075 C      WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
38076        PHKT(5,1)=0.D0
38077       ENDIF
38078       VHKT(1,1)  =VHKK(1,NC1P)
38079       VHKT(2,1)  =VHKK(2,NC1P)
38080       VHKT(3,1)  =VHKK(3,NC1P)
38081       VHKT(4,1)  =VHKK(4,NC1P)
38082       WHKT(1,1)  =WHKK(1,NC1P)
38083       WHKT(2,1)  =WHKK(2,NC1P)
38084       WHKT(3,1)  =WHKK(3,NC1P)
38085       WHKT(4,1)  =WHKK(4,NC1P)
38086 C     Add here IIGLU1 gluons to this chaina
38087       PG1=0.D0
38088       PG2=0.D0
38089       PG3=0.D0
38090       PG4=0.D0
38091       IF(IIGLU1.GE.1)THEN
38092       JJG=NC1P
38093       DO 61 IIG=2,2+IIGLU1-1
38094         KKG=JJG+IIG-1
38095         IDHKT(IIG)   =IDHKK(KKG)
38096         ISTHKT(IIG)  =921
38097         JMOHKT(1,IIG)=KKG
38098         JMOHKT(2,IIG)=0
38099         JDAHKT(1,IIG)=3+IIGLU1
38100         JDAHKT(2,IIG)=0
38101         PHKT(1,IIG)=PHKK(1,KKG)
38102         PG1=PG1+ PHKT(1,IIG)
38103         PHKT(2,IIG)=PHKK(2,KKG)
38104         PG2=PG2+ PHKT(2,IIG)
38105         PHKT(3,IIG)=PHKK(3,KKG)
38106         PG3=PG3+ PHKT(3,IIG)
38107         PHKT(4,IIG)=PHKK(4,KKG)
38108         PG4=PG4+ PHKT(4,IIG)
38109         PHKT(5,IIG)=PHKK(5,KKG)
38110         VHKT(1,IIG)  =VHKK(1,KKG)
38111         VHKT(2,IIG)  =VHKK(2,KKG)
38112         VHKT(3,IIG)  =VHKK(3,KKG)
38113         VHKT(4,IIG)  =VHKK(4,KKG)
38114         WHKT(1,IIG)  =WHKK(1,KKG)
38115         WHKT(2,IIG)  =WHKK(2,KKG)
38116         WHKT(3,IIG)  =WHKK(3,KKG)
38117         WHKT(4,IIG)  =WHKK(4,KKG)
38118    61 CONTINUE
38119       ENDIF
38120 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
38121       IF(IPIP.EQ.1)THEN
38122         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22+3
38123         IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
38124         IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
38125         IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
38126       ELSEIF(IPIP.EQ.2)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       ENDIF
38132       ISTHKT(2+IIGLU1)  =922
38133       JMOHKT(1,2+IIGLU1)=NC2T
38134       JMOHKT(2,2+IIGLU1)=0
38135       JDAHKT(1,2+IIGLU1)=3+IIGLU1
38136       JDAHKT(2,2+IIGLU1)=0
38137       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
38138      *+XGIVE*PHKT(1,5+IIGLU1)
38139       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
38140      *+XGIVE*PHKT(2,5+IIGLU1)
38141       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
38142      *+XGIVE*PHKT(3,5+IIGLU1)
38143       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
38144      *+XGIVE*PHKT(4,5+IIGLU1)
38145 C     PHKT(5,2)  =PHKK(5,NC2T)
38146       XMIST=(PHKT(4,2+IIGLU1)**2-
38147      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38148      *PHKT(1,2+IIGLU1)**2)
38149       IF(XMIST.GT.0.D0)THEN
38150       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
38151      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38152      *PHKT(1,2+IIGLU1)**2)
38153       ELSE
38154 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38155       PHKT(5,2+IIGLU1)=0.D0
38156       ENDIF
38157       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
38158       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
38159       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
38160       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
38161       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
38162       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
38163       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
38164       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
38165       IDHKT(3+IIGLU1)   =88888
38166 C     IDHKT(3)   =1000*NNNC1+MMMC1+10
38167       ISTHKT(3+IIGLU1)  =93
38168 C     ISTHKT(3)  =KKKC1
38169       JMOHKT(1,3+IIGLU1)=1
38170       JMOHKT(2,3+IIGLU1)=2+IIGLU1
38171       JDAHKT(1,3+IIGLU1)=0
38172       JDAHKT(2,3+IIGLU1)=0
38173       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38174       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38175       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38176       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38177       PHKT(5,3+IIGLU1)
38178      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38179      *            -PHKT(3,3+IIGLU1)**2)
38180       IF(IPIP.GE.3)THEN
38181       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38182      * JDAHKT(1,1),
38183      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38184       DO 71 IIG=2,2+IIGLU1-1
38185       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38186      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38187      * JDAHKT(1,IIG),
38188      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38189    71 CONTINUE
38190       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
38191      &             IDHKT(2),JMOHKT(1,2+IIGLU1),
38192      * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38193      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38194       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38195      * JMOHKT(1,3+IIGLU1),
38196      * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38197      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38198       ENDIF
38199       CHAMAL=CHAB1
38200 **NEW
38201 C     IF(IPIP.EQ.1)THEN
38202 C       IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
38203 C     ELSEIF(IPIP.EQ.2)THEN
38204 C       IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
38205 C     ENDIF
38206       IF(IPIP.EQ.1)THEN
38207         IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
38208       ELSEIF(IPIP.EQ.2)THEN
38209         IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
38210       ENDIF
38211 **
38212       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38213 C       IREJ=1
38214         IPCO=0
38215 C       RETURN
38216 C       WRITE(6,*)' MGSQBS1 jump back from chain 3'
38217         GO TO 3466
38218       ENDIF
38219       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
38220       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
38221       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
38222       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
38223       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
38224       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
38225       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
38226       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
38227       IF(IPIP.EQ.1)THEN
38228         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ1+3
38229         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38230         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38231         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38232       ELSEIF(IPIP.EQ.2)THEN
38233         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-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 C       WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
38238       ENDIF
38239       ISTHKT(7+IIGLU1)  =921
38240       JMOHKT(1,7+IIGLU1)=NC2P
38241       JMOHKT(2,7+IIGLU1)=0
38242       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38243       JDAHKT(2,7+IIGLU1)=0
38244 C     PHKT(1,7)  =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
38245 C     PHKT(2,7)  =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
38246 C     PHKT(3,7)  =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
38247 C     PHKT(4,7+IIGLU1)  =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
38248 **NEW
38249       IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
38250      &    WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
38251 **
38252       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38253       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38254       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38255       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38256 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38257 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38258       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38259 C       IREJ=1
38260 C       WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
38261         IPCO=0
38262 C       RETURN
38263         GO TO 3466
38264       ENDIF
38265 C     PHKT(5,7)  =PHKK(5,NC2P)
38266       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
38267      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38268      *PHKT(1,7+IIGLU1)**2)
38269       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
38270       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
38271       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
38272       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
38273       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
38274       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
38275       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
38276       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
38277 C     Insert here the IIGLU2 gluons
38278       PG1=0.D0
38279       PG2=0.D0
38280       PG3=0.D0
38281       PG4=0.D0
38282       IF(IIGLU2.GE.1)THEN
38283       JJG=NC2P
38284       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38285         KKG=JJG+IIG-7-IIGLU1
38286         IDHKT(IIG)   =IDHKK(KKG)
38287         ISTHKT(IIG)  =921
38288         JMOHKT(1,IIG)=KKG
38289         JMOHKT(2,IIG)=0
38290         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38291         JDAHKT(2,IIG)=0
38292         PHKT(1,IIG)=PHKK(1,KKG)
38293         PG1=PG1+ PHKT(1,IIG)
38294         PHKT(2,IIG)=PHKK(2,KKG)
38295         PG2=PG2+ PHKT(2,IIG)
38296         PHKT(3,IIG)=PHKK(3,KKG)
38297         PG3=PG3+ PHKT(3,IIG)
38298         PHKT(4,IIG)=PHKK(4,KKG)
38299         PG4=PG4+ PHKT(4,IIG)
38300         PHKT(5,IIG)=PHKK(5,KKG)
38301         VHKT(1,IIG)  =VHKK(1,KKG)
38302         VHKT(2,IIG)  =VHKK(2,KKG)
38303         VHKT(3,IIG)  =VHKK(3,KKG)
38304         VHKT(4,IIG)  =VHKK(4,KKG)
38305         WHKT(1,IIG)  =WHKK(1,KKG)
38306         WHKT(2,IIG)  =WHKK(2,KKG)
38307         WHKT(3,IIG)  =WHKK(3,KKG)
38308         WHKT(4,IIG)  =WHKK(4,KKG)
38309    81 CONTINUE
38310       ENDIF
38311       IDHKT(8+IIGLU1+IIGLU2)   =IP2
38312       ISTHKT(8+IIGLU1+IIGLU2)  =922
38313       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38314       JMOHKT(2,8+IIGLU1+IIGLU2)=0
38315       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38316       JDAHKT(2,8+IIGLU1+IIGLU2)=0
38317 **NEW
38318       IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
38319      &    WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
38320 **
38321       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38322       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38323       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38324       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38325 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
38326       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38327      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38328      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38329       IF(XMIST.GT.0.D0)THEN
38330       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
38331      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38332      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38333       ELSE
38334 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38335       PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38336       ENDIF
38337       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
38338       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
38339       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
38340       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
38341       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
38342       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
38343       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
38344       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
38345       IDHKT(9+IIGLU1+IIGLU2)   =88888
38346 C     IDHKT(9)   =1000*NNNC2+MMMC2+10
38347       ISTHKT(9+IIGLU1+IIGLU2)  =93
38348 C     ISTHKT(9)  =KKKC2
38349       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38350       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38351       JDAHKT(1,9+IIGLU1+IIGLU2)=0
38352       JDAHKT(2,9+IIGLU1+IIGLU2)=0
38353       PHKT(1,9+IIGLU1+IIGLU2)  =PHKT(1,7+IIGLU1)
38354      * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
38355       PHKT(2,9+IIGLU1+IIGLU2)  =PHKT(2,7+IIGLU1)
38356      * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
38357       PHKT(3,9+IIGLU1+IIGLU2)  =PHKT(3,7+IIGLU1)
38358      * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
38359       PHKT(4,9+IIGLU1+IIGLU2)  =PHKT(4,7+IIGLU1)
38360      * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
38361       PHKT(5,9+IIGLU1+IIGLU2)
38362      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38363      * PHKT(2,9+IIGLU1+IIGLU2)**2
38364      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38365       IF(IPIP.GE.3)THEN
38366       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38367      * JMOHKT(1,7+IIGLU1),
38368      * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38369      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38370       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38371       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38372      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38373      * JDAHKT(1,IIG),
38374      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38375    91 CONTINUE
38376       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38377      * IDHKT(8+IIGLU1+IIGLU2),
38378      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38379      * JDAHKT(1,8+IIGLU1+IIGLU2),
38380      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38381       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38382      * IDHKT(9+IIGLU1+IIGLU2),
38383      * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
38384      * JDAHKT(1,9+IIGLU1+IIGLU2),
38385      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38386       ENDIF
38387       CHAMAL=CHAB1
38388       IF(IPIP.EQ.1)THEN
38389         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38390       ELSEIF(IPIP.EQ.2)THEN
38391         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38392       ENDIF
38393       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38394 C       IREJ=1
38395         IPCO=0
38396 C       RETURN
38397 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
38398 C    &  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38399         GO TO 3466
38400       ENDIF
38401       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
38402       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
38403       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
38404       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
38405       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
38406       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
38407       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
38408       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
38409 C
38410       IGCOUN=9+IIGLU1+IIGLU2
38411       IPCO=0
38412        RETURN
38413        END
38414
38415 *$ CREATE HKKHKT.FOR
38416 *COPY HKKHKT
38417 C
38418 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38419 C
38420       SUBROUTINE HKKHKT(I,J)
38421       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38422       SAVE
38423
38424 * event history
38425
38426       PARAMETER (NMXHKK=200000)
38427
38428       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38429      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38430      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38431
38432 * extended event history
38433       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38434      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38435      &                IHIST(2,NMXHKK)
38436
38437       PARAMETER (NTMHKK= 300)
38438       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38439      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38440      +(4,NTMHKK)
38441 C
38442       ISTHKK(I)  =ISTHKT(J)
38443       IDHKK(I)   =IDHKT(J)
38444 C     IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
38445       IF(IDHKK(I).EQ.88888)THEN
38446 C       JMOHKK(1,I)=I-2
38447 C       JMOHKK(2,I)=I-1
38448         JMOHKK(1,I)=I-(J-JMOHKT(1,J))
38449         JMOHKK(2,I)=I-(J-JMOHKT(2,J))
38450       ELSE
38451         JMOHKK(1,I)=JMOHKT(1,J)
38452         JMOHKK(2,I)=JMOHKT(2,J)
38453       ENDIF
38454       JDAHKK(1,I)=JDAHKT(1,J)
38455       JDAHKK(2,I)=JDAHKT(2,J)
38456 C       IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
38457 C       JDAHKK(1,I)=I+2
38458 C     ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
38459 C       JDAHKK(1,I)=I+1
38460 C     ENDIF
38461       IF(JDAHKT(1,J).GT.0)THEN
38462         JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
38463       ENDIF
38464       PHKK(1,I)  =PHKT(1,J)
38465       PHKK(2,I)  =PHKT(2,J)
38466       PHKK(3,I)  =PHKT(3,J)
38467       PHKK(4,I)  =PHKT(4,J)
38468       PHKK(5,I)  =PHKT(5,J)
38469       VHKK(1,I)  =VHKT(1,J)
38470       VHKK(2,I)  =VHKT(2,J)
38471       VHKK(3,I)  =VHKT(3,J)
38472       VHKK(4,I)  =VHKT(4,J)
38473       WHKK(1,I)  =WHKT(1,J)
38474       WHKK(2,I)  =WHKT(2,J)
38475       WHKK(3,I)  =WHKT(3,J)
38476       WHKK(4,I)  =WHKT(4,J)
38477       RETURN
38478       END
38479
38480 *$ CREATE DT_DBREAK.FOR
38481 *COPY DT_DBREAK
38482 *
38483 *===dbreak=============================================================*
38484 *
38485       SUBROUTINE DT_DBREAK(MODE)
38486
38487 ************************************************************************
38488 * This is the steering subroutine for the different diquark breaking   *
38489 * mechanisms.                                                          *
38490 *                                                                      *
38491 * MODE = 1  breaking of projectile diquark in qq-q chain using         *
38492 *           a sea quark (q-qq chain) of the same projectile            *
38493 *      = 2  breaking of target     diquark in q-qq chain using         *
38494 *           a sea quark (qq-q chain) of the same target                *
38495 *      = 3  breaking of projectile diquark in qq-q chain using         *
38496 *           a sea quark (q-aq chain) of the same projectile            *
38497 *      = 4  breaking of target     diquark in q-qq chain using         *
38498 *           a sea quark (aq-q chain) of the same target                *
38499 *      = 5  breaking of projectile anti-diquark in aqaq-aq chain using *
38500 *           a sea anti-quark (aq-aqaq chain) of the same projectile    *
38501 *      = 6  breaking of target     anti-diquark in aq-aqaq chain using *
38502 *           a sea anti-quark (aqaq-aq chain) of the same target        *
38503 *      = 7  breaking of projectile anti-diquark in aqaq-aq chain using *
38504 *           a sea anti-quark (aq-q chain) of the same projectile       *
38505 *      = 8  breaking of target     anti-diquark in aq-aqaq chain using *
38506 *           a sea anti-quark (q-aq chain) of the same target           *
38507 *                                                                      *
38508 * Original version by J. Ranft.                                        *
38509 * This version dated 17.5.00  is written by S. Roesler.                *
38510 ************************************************************************
38511
38512       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38513       SAVE
38514
38515       PARAMETER ( LINP = 10 ,
38516      &            LOUT = 6 ,
38517      &            LDAT = 9 )
38518
38519 * event history
38520
38521       PARAMETER (NMXHKK=200000)
38522
38523       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38524      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38525      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38526
38527 * extended event history
38528       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38529      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38530      &                IHIST(2,NMXHKK)
38531
38532 * flags for input different options
38533       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
38534       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
38535      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
38536
38537 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
38538       PARAMETER (MAXCHN=10000)
38539       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
38540
38541 * diquark-breaking mechanism
38542       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38543
38544 * flags for particle decays
38545       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
38546      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
38547      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
38548
38549 *
38550 * chain identifiers
38551 * ( 1 = q-aq,   2 = aq-q,   3 = q-qq,   4 = qq-q,
38552 *   5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
38553       DIMENSION IDCHN1(8),IDCHN2(8)
38554       DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
38555       DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
38556 *
38557 * parton identifiers
38558 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
38559 *   +-51/52 = unitarity-sea, +-61/62 = gluons )
38560       DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
38561       DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
38562      &             31, 31, 31, 31, 31, 31, 31, 31,
38563      &             41, 41, 41, 41, 51, 51, 51, 51/
38564       DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
38565      &             32, 32, 32, 32, 32, 32, 32, 32,
38566      &             42, 42, 42, 42, 52, 52, 52, 52/
38567       DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
38568      &             51, 31, 41, 41, 31, 31, 31, 31,
38569      &              0, 41, 51, 51, 51, 51, 51, 51/
38570       DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
38571      &             32, 52, 42, 42, 32, 32, 32, 32,
38572      &             42,  0, 52, 52, 52, 52, 52, 52/
38573
38574       IF (NCHAIN.LE.0) RETURN
38575       DO 1 I=1,NCHAIN
38576          IDX1 = IDXCHN(1,I)
38577          IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
38578          IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
38579          IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
38580      &       .AND.
38581      &        ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
38582      &                                    (IS1P.EQ.ISP1P(MODE,3)))
38583      &       .AND.
38584      &        ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
38585      &                                    (IS1T.EQ.ISP1T(MODE,3)))
38586      &      ) THEN
38587             DO 2 J=1,NCHAIN
38588                IDX2 = IDXCHN(1,J)
38589                IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
38590                IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
38591                IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
38592      &             .AND.
38593      &              ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
38594      &                                      .OR.(IS2P.EQ.ISP2P(MODE,3)))
38595      &             .AND.
38596      &              ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
38597      &                                      .OR.(IS2T.EQ.ISP2T(MODE,3)))
38598      &            ) THEN
38599 *   find mother nucleons of the diquark to be splitted and of the
38600 *   sea-quark and reject this combination if it is not the same
38601                   IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
38602      &                (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
38603                      IANCES = 1
38604                   ELSE
38605                      IANCES = 2
38606                   ENDIF
38607                   IDXMO1 = JMOHKK(IANCES,IDX1)
38608     4             CONTINUE
38609                   IF ((JMOHKK(1,IDXMO1).NE.0).AND.
38610      &                (JMOHKK(2,IDXMO1).NE.0)) THEN
38611                      IANC = IANCES
38612                   ELSE
38613                      IANC = 1
38614                   ENDIF
38615                   IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
38616                      IDXMO1 = JMOHKK(IANC,IDXMO1)
38617                      GOTO 4
38618                   ENDIF
38619                   IDXMO2 = JMOHKK(IANCES,IDX2)
38620     5             CONTINUE
38621                   IF ((JMOHKK(1,IDXMO2).NE.0).AND.
38622      &                (JMOHKK(2,IDXMO2).NE.0)) THEN
38623                      IANC = IANCES
38624                   ELSE
38625                      IANC = 1
38626                   ENDIF
38627                   IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
38628                      IDXMO2 = JMOHKK(IANC,IDXMO2)
38629                      GOTO 5
38630                   ENDIF
38631                   IF (IDXMO1.NE.IDXMO2) GOTO 2
38632 *   quark content of projectile parton
38633                   IP1   = IDHKK(JMOHKK(1,IDX1))
38634                   IP11  = IP1/1000
38635                   IP12  = (IP1-1000*IP11)/100
38636                   IP2   = IDHKK(JMOHKK(2,IDX1))
38637                   IP21  = IP2/1000
38638                   IP22  = (IP2-1000*IP21)/100
38639 *   quark content of target parton
38640                   IT1  = IDHKK(JMOHKK(1,IDX2))
38641                   IT11 = IT1/1000
38642                   IT12 = (IT1-1000*IT11)/100
38643                   IT2  = IDHKK(JMOHKK(2,IDX2))
38644                   IT21 = IT2/1000
38645                   IT22 = (IT2-1000*IT21)/100
38646 *   split diquark and form new chains
38647                   IF (MODE.EQ.1) THEN
38648                      IF (IT1.EQ.4) GOTO 2
38649                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38650      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38651      &                         IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
38652                   ELSEIF (MODE.EQ.2) THEN
38653                      IF (IT2.EQ.4) GOTO 2
38654                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38655      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38656      &                         IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
38657                   ELSEIF (MODE.EQ.3) THEN
38658                      IF (IT1.EQ.4) GOTO 2
38659                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38660      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38661      &                         IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
38662                   ELSEIF (MODE.EQ.4) THEN
38663                      IF (IT2.EQ.4) GOTO 2
38664                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38665      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38666      &                         IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
38667                   ELSEIF (MODE.EQ.5) THEN
38668                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38669      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38670      &                         IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
38671                   ELSEIF (MODE.EQ.6) THEN
38672                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38673      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38674      &                         IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
38675                   ELSEIF (MODE.EQ.7) THEN
38676                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38677      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38678      &                         IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
38679                   ELSEIF (MODE.EQ.8) THEN
38680                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38681      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38682      &                         IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
38683                   ENDIF
38684                   IF (IREJ.GE.1) THEN
38685                      if ((ipq.lt.0).or.(ipq.ge.4))
38686      &                  write(LOUT,*) 'ipq !!!',ipq,mode
38687                      DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38688 *   accept or reject new chains corresponding to PDBSEA
38689                   ELSE
38690                      IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
38691                         ACC   = DBRKA(1,MODE)+DBRKA(2,MODE)
38692                         REJ   = DBRKR(1,MODE)+DBRKR(2,MODE)
38693                      ELSEIF (IPQ.EQ.3) THEN
38694                         ACC   = DBRKA(3,MODE)
38695                         REJ   = DBRKR(3,MODE)
38696                      ELSE
38697                         WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
38698                         STOP
38699                      ENDIF
38700                      IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
38701                         DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
38702                         IACC = 1
38703                      ELSE
38704                         DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38705                         IACC = 0
38706                      ENDIF
38707 *   new chains have been accepted and are now copied into HKKEVT
38708                      IF (IACC.EQ.1) THEN
38709                         IF (LEMCCK) THEN
38710                            CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
38711      &                                    PHKK(3,IDX1),PHKK(4,IDX1),
38712      &                                    1,IDUM1,IDUM2)
38713                            CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
38714      &                                    PHKK(3,IDX2),PHKK(4,IDX2),
38715      &                                    2,IDUM1,IDUM2)
38716                         ENDIF
38717                         IDHKK(IDX1) = 99888
38718                         IDHKK(IDX2) = 99888
38719                         IDXCHN(2,I) = -1
38720                         IDXCHN(2,J) = -1
38721                         DO 3 K=1,IGCOUN
38722                            NHKK = NHKK+1
38723                            CALL HKKHKT(NHKK,K)
38724                            IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
38725                               PX = -PHKK(1,NHKK)
38726                               PY = -PHKK(2,NHKK)
38727                               PZ = -PHKK(3,NHKK)
38728                               PE = -PHKK(4,NHKK)
38729                               CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
38730                            ENDIF
38731     3                   CONTINUE
38732                         IF (LEMCCK) THEN
38733                            CHKLEV = 0.1D0
38734                            CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
38735      &                                                             IREJ)
38736                            IF (IREJ.NE.0) CALL DT_EVTOUT(4)
38737                         ENDIF
38738                         GOTO 1
38739                      ENDIF
38740                   ENDIF
38741                ENDIF
38742     2       CONTINUE
38743          ENDIF
38744     1 CONTINUE
38745       RETURN
38746       END
38747
38748 *$ CREATE DT_CQPAIR.FOR
38749 *COPY DT_CQPAIR
38750 *
38751 *===cqpair=============================================================*
38752 *
38753       SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
38754
38755 ************************************************************************
38756 * This subroutine Creates a Quark-antiquark PAIR from the sea.         *
38757 *                                                                      *
38758 *   XQMAX   maxium energy fraction of quark (input)                    *
38759 *   XAQMAX  maxium energy fraction of antiquark (input)                *
38760 *   XQ      energy fraction of quark (output)                          *
38761 *   XAQ     energy fraction of antiquark (output)                      *
38762 *   IFLV    quark flavour (- antiquark flavor) (output)                *
38763 *                                                                      *
38764 * This version dated 14.5.00  is written by S. Roesler.                *
38765 ************************************************************************
38766
38767       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38768       SAVE
38769
38770       PARAMETER ( LINP = 10 ,
38771      &            LOUT = 6 ,
38772      &            LDAT = 9 )
38773
38774 * Lorentz-parameters of the current interaction
38775       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38776      &                UMO,PPCM,EPROJ,PPROJ
38777
38778 *
38779       IREJ = 0
38780       XQ   = 0.0D0
38781       XAQ  = 0.0D0
38782 *
38783 * sample quark flavour
38784 *
38785 *  set seasq here (the one from DTCHAI should be used in the future)
38786       SEASQ = 0.5D0
38787       IFLV  = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
38788 *
38789 * sample energy fractions of sea pair
38790 * we first sample the energy fraction of a gluon and then split the gluon
38791 *
38792 *  maximum energy fraction of the gluon forced via input
38793       XGMAXI = XQMAX+XAQMAX
38794 *  minimum energy fraction of the gluon
38795       XTHR1 = 4.0D0 /UMO**2
38796       XTHR2 = 0.54D0/UMO**1.5D0
38797       XGMIN = MAX(XTHR1,XTHR2)
38798 *  maximum energy fraction of the gluon
38799       XGMAX = 0.3D0
38800       XGMAX = MIN(XGMAXI,XGMAX)
38801       IF (XGMIN.GE.XGMAX) THEN
38802          IREJ = 1
38803          RETURN
38804       ENDIF
38805 *
38806 *  sample energy fraction of the gluon
38807       NLOOP = 0
38808     1 CONTINUE
38809       NLOOP = NLOOP+1
38810       IF (NLOOP.GE.50) THEN
38811          IREJ = 1
38812          RETURN
38813       ENDIF
38814       XGLUON = DT_SAMSQX(XGMIN,XGMAX)
38815       EGLUON = XGLUON*UMO/2.0D0
38816 *
38817 *  split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
38818       ZMIN = MIN(0.1D0,0.5D0/EGLUON)
38819       ZMAX = 1.0D0-ZMIN
38820       RZ   = DT_RNDM(ZMAX)
38821       XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
38822       RQ   = DT_RNDM(ZMAX)
38823       IF (RQ.LT.0.5D0) THEN
38824          XQ  = XGLUON*XHLP
38825          XAQ = XGLUON-XQ
38826       ELSE
38827          XAQ = XGLUON*XHLP
38828          XQ  = XGLUON-XAQ
38829       ENDIF
38830       IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
38831
38832       RETURN
38833       END