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             IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
3596      &                                   (ISTHKK(I).EQ.1001)) THEN
3597                CALL DT_MYTRAN(1,PHKK(1,I),PHKK(2,I),PHKK(3,I),
3598      &                     COD,SID,COF,SIF,PXCMS,PYCMS,PZCMS)
3599                PECMS = PHKK(4,I)
3600                CALL DT_DALTRA(BGE,BGX,BGY,BGZ,PXCMS,PYCMS,PZCMS,PECMS,
3601      &                     PTOT,PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I))
3602             ENDIF
3603    20    CONTINUE
3604       ELSE
3605          MODE = -1
3606       ENDIF
3607
3608       RETURN
3609       END
3610
3611 *$ CREATE DT_REJUCO.FOR
3612 *COPY DT_REJUCO
3613 *
3614 *===rejuco=============================================================*
3615 *
3616       SUBROUTINE DT_REJUCO(MODE,IREJ)
3617
3618 ************************************************************************
3619 * REJection of Unphysical COnfigurations                               *
3620 *     MODE = 1  rejection of particles with unphysically large energy  *
3621 *                                                                      *
3622 * This version dated 27.12.2006 is written by S. Roesler.              *
3623 ************************************************************************
3624
3625       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3626       SAVE
3627
3628       PARAMETER ( LINP = 10 ,
3629      &            LOUT = 6 ,
3630      &            LDAT = 9 )
3631
3632       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10)
3633       PARAMETER (TWOPI=6.283185307D0,BOG=TWOPI/360.0D0)
3634
3635 * maximum x_cms of final state particle
3636       PARAMETER (XCMSMX = 1.4D0)
3637
3638 * event history
3639
3640       PARAMETER (NMXHKK=200000)
3641
3642       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3643      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3644      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3645
3646 * extended event history
3647       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3648      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3649      &                IHIST(2,NMXHKK)
3650
3651 * Lorentz-parameters of the current interaction
3652       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
3653      &                UMO,PPCM,EPROJ,PPROJ
3654
3655       IREJ = 0
3656
3657       IF (MODE.EQ.1) THEN
3658          IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
3659          ECMHLF = UMO/2.0D0
3660          DO 10 I=NPOINT(4),NHKK
3661             IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDHKK(I).NE.80000)) THEN
3662                XCMS = ABS(PHKK(4,I))/ECMHLF
3663                IF (XCMS.GT.XCMSMX) GOTO 9999
3664             ENDIF
3665    10    CONTINUE
3666       ENDIF
3667
3668       RETURN
3669  9999 CONTINUE
3670       IREJ = 1
3671       RETURN
3672       END
3673 *$ CREATE DT_EVENTB.FOR
3674 *COPY DT_EVENTB
3675 *
3676 *===eventb=============================================================*
3677 *
3678       SUBROUTINE DT_EVENTB(NCSY,IREJ)
3679
3680 ************************************************************************
3681 * Treatment of nucleon-nucleon interactions with full two-component    *
3682 * Dual Parton Model.                                                   *
3683 *          NCSY     number of nucleon-nucleon interactions             *
3684 *          IREJ     rejection flag                                     *
3685 * This version dated 14.01.2000 is written by S. Roesler               *
3686 ************************************************************************
3687
3688       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
3689       SAVE
3690
3691       PARAMETER ( LINP = 10 ,
3692      &            LOUT = 6 ,
3693      &            LDAT = 9 )
3694
3695       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
3696
3697 * event history
3698
3699       PARAMETER (NMXHKK=200000)
3700
3701       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
3702      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
3703      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
3704
3705 * extended event history
3706       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
3707      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
3708      &                IHIST(2,NMXHKK)
3709 *! uncomment this line for internal phojet-fragmentation
3710 C #include "dtu_dtevtp.inc"
3711
3712 * particle properties (BAMJET index convention)
3713       CHARACTER*8  ANAME
3714       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
3715      &                IICH(210),IIBAR(210),K1(210),K2(210)
3716
3717 * flags for input different options
3718       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
3719       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
3720      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
3721
3722 * rejection counter
3723       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
3724      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
3725      &                IREXCI(3),IRDIFF(2),IRINC
3726
3727 * properties of interacting particles
3728       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
3729
3730 * properties of photon/lepton projectiles
3731       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
3732
3733 * various options for treatment of partons (DTUNUC 1.x)
3734 * (chain recombination, Cronin,..)
3735       LOGICAL LCO2CR,LINTPT
3736       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
3737      &                LCO2CR,LINTPT
3738
3739 * statistics
3740       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
3741      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
3742      &                ICEVTG(8,0:30)
3743
3744 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
3745       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
3746
3747 * Glauber formalism: collision properties
3748       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
3749      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
3750
3751 * flags for diffractive interactions (DTUNUC 1.x)
3752       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
3753
3754 * statistics: double-Pomeron exchange
3755       COMMON /DTFLG2/ INTFLG,IPOPO
3756
3757 * flags for particle decays
3758       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
3759      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
3760      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
3761
3762 * nucleon-nucleon event-generator
3763       CHARACTER*8 CMODEL
3764       LOGICAL LPHOIN
3765       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
3766
3767 C  nucleon-nucleus / nucleus-nucleus interface to DPMJET
3768       INTEGER IDEQP,IDEQB,IHFLD,IHFLS
3769       DOUBLE PRECISION ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB
3770       COMMON /POHDFL/ ECMN,PCMN,SECM,SPCM,XPSUB,XTSUB,
3771      &                IDEQP(2),IDEQB(2),IHFLD(2,2),IHFLS(2)
3772
3773 C  model switches and parameters
3774       CHARACTER*8 MDLNA
3775       INTEGER ISWMDL,IPAMDL
3776       DOUBLE PRECISION PARMDL
3777       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
3778
3779 C  initial state parton radiation (internal part)
3780       INTEGER MXISR3,MXISR4
3781       PARAMETER ( MXISR3 = 50, MXISR4 = 100 )
3782       INTEGER IFL1,IFL2,IBRA,IFANO,ISH,NACC
3783       DOUBLE PRECISION Q2SH,PT2SH,XPSH,ZPSH,THSH,SHAT
3784       COMMON /POINT6/ Q2SH(2,MXISR3),PT2SH(2,MXISR3),XPSH(2,MXISR3),
3785      &                ZPSH(2,MXISR3),THSH(2,MXISR3),SHAT(MXISR3),
3786      &                IFL1(2,MXISR3),IFL2(2,MXISR3),
3787      &                IBRA(2,MXISR4),IFANO(2),ISH(2),NACC
3788
3789 C  event debugging information
3790       INTEGER NMAXD
3791       PARAMETER (NMAXD=100)
3792       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
3793      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3794       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
3795      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
3796
3797 C  general process information
3798       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
3799       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
3800
3801       DIMENSION PP(4),PT(4),PTOT(4),PP1(4),PP2(4),PT1(4),PT2(4),
3802      &          PPNN(4),PTNN(4),PTOTNN(4),PPSUB(4),PTSUB(4),
3803      &          PPTCMS(4),PTTCMS(4),PPTMP(4),PTTMP(4),
3804      &          KPRON(15),ISINGL(2000)
3805
3806 * initial values for max. number of phojet scatterings and dtunuc chains
3807 * to be fragmented with one pyexec call
3808       DATA MXPHFR,MXDTFR /10,100/
3809
3810       IREJ      = 0
3811 * pointer to first parton of the first chain in dtevt common
3812       NPOINT(3) = NHKK+1
3813 * special flag for double-Pomeron statistics
3814       IPOPO = 1
3815 * counter for low-mass (DTUNUC) interactions
3816       NDTUSC = 0
3817 * counter for interactions treated by PHOJET
3818       NPHOSC = 0
3819
3820 * scan interactions for single nucleon-nucleon interactions
3821 * (this has to be checked here because Cronin modifies parton momenta)
3822       NC = NPOINT(2)
3823       IF (NCSY.GT.2000) STOP ' DT_EVENTB: NCSY > 2000 ! '
3824       DO 8 I=1,NCSY
3825          ISINGL(I) = 0
3826          MOP = JMOHKK(1,NC)
3827          MOT = JMOHKK(1,NC+1)
3828          DIFF1 = ABS(PHKK(4,MOP)-PHKK(4,  NC)-PHKK(4,NC+2))
3829          DIFF2 = ABS(PHKK(4,MOT)-PHKK(4,NC+1)-PHKK(4,NC+3))
3830          IF ((DIFF1.LT.TINY10).AND.(DIFF2.LT.TINY10)) ISINGL(I) = 1
3831          NC = NC+4
3832     8 CONTINUE
3833
3834 * multiple scattering of chain ends
3835       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
3836       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
3837
3838 * switch to PHOJET-settings for JETSET parameter
3839       CALL DT_INITJS(1)
3840
3841 * loop over nucleon-nucleon interaction
3842       NC = NPOINT(2)
3843       DO 2 I=1,NCSY
3844 *
3845 *   pick up one nucleon-nucleon interaction from DTEVT1
3846 *     ppnn  / ptnn   - momenta of the interacting nucleons (cms)
3847 *     ptotnn         - total momentum of the interacting nucleons (cms)
3848 *     pp1,2 / pt1,2  - momenta of the four partons
3849 *     pp    / pt     - total momenta of the proj / targ partons
3850 *     ptot           - total momentum of the four partons
3851          MOP = JMOHKK(1,NC)
3852          MOT = JMOHKK(1,NC+1)
3853          DO 3 K=1,4
3854             PPNN(K)   = PHKK(K,MOP)
3855             PTNN(K)   = PHKK(K,MOT)
3856             PTOTNN(K) = PPNN(K)+PTNN(K)
3857             PP1(K)    = PHKK(K,NC)
3858             PT1(K)    = PHKK(K,NC+1)
3859             PP2(K)    = PHKK(K,NC+2)
3860             PT2(K)    = PHKK(K,NC+3)
3861             PP(K)     = PP1(K)+PP2(K)
3862             PT(K)     = PT1(K)+PT2(K)
3863             PTOT(K)   = PP(K)+PT(K)
3864     3    CONTINUE
3865 *
3866 *-----------------------------------------------------------------------
3867 *   this is a complete nucleon-nucleon interaction
3868 *
3869          IF (ISINGL(I).EQ.1) THEN
3870 *
3871 *     initialize PHOJET-variables for remnant/valence-partons
3872             IHFLD(1,1) = 0
3873             IHFLD(1,2) = 0
3874             IHFLD(2,1) = 0
3875             IHFLD(2,2) = 0
3876             IHFLS(1) = 1
3877             IHFLS(2) = 1
3878 *     save current settings of PHOJET process and min. bias flags
3879             DO 9 K=1,11
3880                KPRON(K) = IPRON(K,1)
3881     9       CONTINUE
3882             ISWSAV   = ISWMDL(2)
3883 *
3884 *     check if forced sampling of diffractive interaction requested
3885             IF (ISINGD.LT.-1) THEN
3886                DO 90 K=1,11
3887                   IPRON(K,1) = 0
3888    90          CONTINUE
3889                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-3)) IPRON(5,1) = 1
3890                IF ((ISINGD.EQ.-2).OR.(ISINGD.EQ.-4)) IPRON(6,1) = 1
3891                IF (ISINGD.EQ.-5) IPRON(4,1) = 1
3892             ENDIF
3893 *
3894 *     for photons: a direct/anomalous interaction is not sampled
3895 *     in PHOJET but already in Glauber-formalism. Here we check if such
3896 *     an interaction is requested
3897             IF (IJPROJ.EQ.7) THEN
3898 *       first switch off direct interactions
3899                IPRON(8,1) = 0
3900 *       this is a direct interactions
3901                IF (IDIREC.EQ.1) THEN
3902                   DO 12 K=1,11
3903                      IPRON(K,1) = 0
3904    12             CONTINUE
3905                   IPRON(8,1) = 1
3906 *       this is an anomalous interactions
3907 *         (iswmdl(2) = 0 only hard int. generated ( = 1 min. bias) )
3908                ELSEIF (IDIREC.EQ.2) THEN
3909                   ISWMDL(2) = 0
3910                ENDIF
3911             ELSE
3912                IF (IDIREC.NE.0) STOP ' DT_EVENTB: IDIREC > 0 ! '
3913             ENDIF
3914 *
3915 *     make sure that total momenta of partons, pp and pt, are on mass
3916 *     shell (Cronin may have srewed this up..)
3917             CALL DT_MASHEL(PP,PT,PHKK(5,MOP),PHKK(5,MOT),PPNN,PTNN,IR1)
3918             IF (IR1.NE.0) THEN
3919                IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A)')
3920      &              'EVENTB:  mass shell correction rejected'
3921                GOTO 9999
3922             ENDIF
3923 *
3924 *     initialize the incoming particles in PHOJET
3925             IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
3926
3927                CALL PHO_SETPAR(1,22,0,VIRT)
3928
3929             ELSE
3930
3931                CALL PHO_SETPAR(1,IDHKK(MOP),0,ZERO)
3932
3933             ENDIF
3934
3935             CALL PHO_SETPAR(2,IDHKK(MOT),0,ZERO)
3936
3937 *
3938 *     initialize rejection loop counter for anomalous processes
3939             IRJANO = 0
3940   800       CONTINUE
3941             IRJANO = IRJANO+1
3942 *
3943 *     temporary fix for ifano problem
3944             IFANO(1) = 0
3945             IFANO(2) = 0
3946 *
3947 *     generate complete hadron/nucleon/photon-nucleon event with PHOJET
3948
3949             CALL PHO_EVENT(2,PPNN,PTNN,DUM,IREJ1)
3950
3951 *
3952 *     for photons: special consistency check for anomalous interactions
3953             IF (IJPROJ.EQ.7) THEN
3954                IF (IRJANO.LT.30) THEN
3955                   IF (IFANO(1).NE.0) THEN
3956 *       here, an anomalous interaction was generated. Check if it
3957 *       was also requested. Otherwise reject this event.
3958                      IF (IDIREC.EQ.0) GOTO 800
3959                   ELSE
3960 *       here, an anomalous interaction was not generated. Check if it
3961 *       was requested in which case we need to reject this event.
3962                      IF (IDIREC.EQ.2) GOTO 800
3963                   ENDIF
3964                ELSE
3965                   WRITE(LOUT,*) ' DT_EVENTB: Warning! IRJANO > 30 ',
3966      &                          IRJANO,IDIREC,NEVHKK
3967                ENDIF
3968             ENDIF
3969 *
3970 *     copy back original settings of PHOJET process and min. bias flags
3971             DO 10 K=1,11
3972                IPRON(K,1) = KPRON(K)
3973    10       CONTINUE
3974             ISWMDL(2) = ISWSAV
3975 *
3976 *     check if PHOJET has rejected this event
3977             IF (IREJ1.NE.0) THEN
3978 C              IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
3979                WRITE(LOUT,'(1X,A,I4)')
3980      &            'EVENTB:  chain system rejected',IDIREC
3981
3982                CALL PHO_PREVNT(0)
3983
3984                GOTO 9999
3985             ENDIF
3986 *
3987 *     copy partons and strings from PHOJET common back into DTEVT for
3988 *     external fragmentation
3989             MO1 = NC
3990             MO2 = NC+3
3991 *!      uncomment this line for internal phojet-fragmentation
3992 C           CALL DT_GETFSP(MO1,MO2,PPNN,PTNN,-1)
3993             NPHOSC = NPHOSC+1
3994             CALL DT_GETPJE(MO1,MO2,PPNN,PTNN,-1,NPHOSC,IREJ1)
3995             IF (IREJ1.NE.0) THEN
3996                IF (IOULEV(1).GT.0)
3997      &         WRITE(LOUT,'(1X,A,I4)') 'EVENTB: chain system rejected 1'
3998                GOTO 9999
3999             ENDIF
4000 *
4001 *     update statistics counter
4002             ICEVTG(IDCH(NC),29) = ICEVTG(IDCH(NC),29)+1
4003 *
4004 *-----------------------------------------------------------------------
4005 *   this interaction involves "remnants"
4006 *
4007          ELSE
4008 *
4009 *     total mass of this system
4010             PPTOT  = SQRT(PTOT(1)**2+PTOT(2)**2+PTOT(3)**2)
4011             AMTOT2 = (PTOT(4)-PPTOT)*(PTOT(4)+PPTOT)
4012             IF (AMTOT2.LT.ZERO) THEN
4013                AMTOT = ZERO
4014             ELSE
4015                AMTOT = SQRT(AMTOT2)
4016             ENDIF
4017 *
4018 *     systems with masses larger than elojet are treated with PHOJET
4019             IF (AMTOT.GT.ELOJET) THEN
4020 *
4021 *     initialize PHOJET-variables for remnant/valence-partons
4022 *       projectile parton flavors and valence flag
4023                IHFLD(1,1) = IDHKK(NC)
4024                IHFLD(1,2) = IDHKK(NC+2)
4025                IHFLS(1)   = 0
4026                IF ((IDCH(NC).EQ.6).OR.(IDCH(NC).EQ.7)
4027      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(1) = 1
4028 *       target parton flavors and valence flag
4029                IHFLD(2,1) = IDHKK(NC+1)
4030                IHFLD(2,2) = IDHKK(NC+3)
4031                IHFLS(2)   = 0
4032                IF ((IDCH(NC).EQ.4).OR.(IDCH(NC).EQ.5)
4033      &                            .OR.(IDCH(NC).EQ.8)) IHFLS(2) = 1
4034 *       flag signalizing PHOJET how to treat the remnant:
4035 *         iremn = -1 sea-quark remnant: PHOJET takes flavors from ihfld
4036 *         iremn > -1 valence remnant: PHOJET assumes flavors according
4037 *                    to mother particle
4038                IREMN1 = IHFLS(1)-1
4039                IREMN2 = IHFLS(2)-1
4040 *
4041 *     initialize the incoming particles in PHOJET
4042                IF ((IP.EQ.1).AND.(IJPROJ.EQ.7)) THEN
4043
4044                   CALL PHO_SETPAR(1,22,IREMN1,VIRT)
4045
4046                ELSE
4047
4048                   CALL PHO_SETPAR(1,IDHKK(MOP),IREMN1,ZERO)
4049
4050                ENDIF
4051
4052                CALL PHO_SETPAR(2,IDHKK(MOT),IREMN2,ZERO)
4053
4054 *
4055 *     calculate Lorentz parameter of the nucleon-nucleon cm-system
4056                PPTOTN = SQRT(PTOTNN(1)**2+PTOTNN(2)**2+PTOTNN(3)**2)
4057                AMNN   = SQRT( (PTOTNN(4)-PPTOTN)*(PTOTNN(4)+PPTOTN) )
4058                BGX    = PTOTNN(1)/AMNN
4059                BGY    = PTOTNN(2)/AMNN
4060                BGZ    = PTOTNN(3)/AMNN
4061                GAM    = PTOTNN(4)/AMNN
4062 *     transform interacting nucleons into nucleon-nucleon cm-system
4063                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4064      &                     PPNN(1),PPNN(2),PPNN(3),PPNN(4),PPCMS,
4065      &                     PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4))
4066                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4067      &                     PTNN(1),PTNN(2),PTNN(3),PTNN(4),PTCMS,
4068      &                     PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4))
4069 *     transform (total) momenta of the proj and targ partons into
4070 *     nucleon-nucleon cm-system
4071                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4072      &                     PP(1),PP(2),PP(3),PP(4),
4073      &                     PPTSUB,PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4))
4074                CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,
4075      &                     PT(1),PT(2),PT(3),PT(4),
4076      &                     PTTSUB,PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4))
4077 *     energy fractions of the proj and targ partons
4078                XPSUB = MIN(PPSUB(4)/PPTCMS(4),ONE)
4079                XTSUB = MIN(PTSUB(4)/PTTCMS(4),ONE)
4080 ***
4081 * testprint
4082 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
4083 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
4084 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
4085 c              EOLDCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
4086 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
4087 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
4088 c    &                        (PPSUB(2)+PTSUB(2))**2 +
4089 c    &                        (PPSUB(3)+PTSUB(3))**2 )
4090 c              EOLDSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
4091 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
4092 ***
4093 *
4094 *     save current settings of PHOJET process and min. bias flags
4095                DO 7 K=1,11
4096                   KPRON(K) = IPRON(K,1)
4097     7          CONTINUE
4098 *     disallow direct photon int. (does not make sense here anyway)
4099                IPRON(8,1) = 0
4100 *     disallow double pomeron processes (due to technical problems
4101 *     in PHOJET, needs to be solved sometime)
4102                IPRON(4,1) = 0
4103 *     disallow diffraction for sea-diquarks
4104                IF ((IABS(IHFLD(1,1)).GT.1100).AND.
4105      &             (IABS(IHFLD(1,2)).GT.1100)) THEN
4106                   IPRON(3,1) = 0
4107                   IPRON(6,1) = 0
4108                ENDIF
4109                IF ((IABS(IHFLD(2,1)).GT.1100).AND.
4110      &             (IABS(IHFLD(2,2)).GT.1100)) THEN
4111                   IPRON(3,1) = 0
4112                   IPRON(5,1) = 0
4113                ENDIF
4114 *
4115 *     we need massless partons: transform them on mass shell
4116                XMP = ZERO
4117                XMT = ZERO
4118                DO 6 K=1,4
4119                   PPTMP(K) = PPSUB(K)
4120                   PTTMP(K) = PTSUB(K)
4121     6          CONTINUE
4122                CALL DT_MASHEL(PPTMP,PTTMP,XMP,XMT,PPSUB,PTSUB,IREJ1)
4123                PPSUTO  = SQRT(PPSUB(1)**2+PPSUB(2)**2+PPSUB(3)**2)
4124                PTSUTO  = SQRT(PTSUB(1)**2+PTSUB(2)**2+PTSUB(3)**2)
4125                PSUTOT = SQRT((PPSUB(1)+PTSUB(1))**2+
4126      &                  (PPSUB(2)+PTSUB(2))**2+(PPSUB(3)+PTSUB(3))**2)
4127 *     total energy of the subsysten after mass transformation
4128 *      (should be the same as before..)
4129                SECM = SQRT( (PPSUB(4)+PTSUB(4)-PSUTOT)*
4130      &                      (PPSUB(4)+PTSUB(4)+PSUTOT) )
4131 *
4132 *     after mass shell transformation the x_sub - relation has to be
4133 *     corrected. We therefore create "pseudo-momenta" of mother-nucleons.
4134 *
4135 *     The old version was to scale based on the original x_sub and the
4136 *     4-momenta of the subsystem. At very high energy this could lead to
4137 *     "pseudo-cm energies" of the parent system considerably exceeding
4138 *     the true cm energy. Now we keep the true cm energy and calculate
4139 *     new x_sub instead.
4140 C old version  PPTCMS(4) = PPSUB(4)/XPSUB
4141                PPTCMS(4) = MAX(PPTCMS(4),PPSUB(4))
4142                XPSUB = PPSUB(4)/PPTCMS(4)
4143                IF (IJPROJ.EQ.7) THEN
4144                   AMP2  = PHKK(5,MOT)**2
4145                   PTOT1 = SQRT(PPTCMS(4)**2-AMP2)
4146                ELSE
4147 *???????
4148                   PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOP))
4149      &                        *(PPTCMS(4)+PHKK(5,MOP)))
4150 C                 PTOT1 = SQRT((PPTCMS(4)-PHKK(5,MOT))
4151 C    &                        *(PPTCMS(4)+PHKK(5,MOT)))
4152                ENDIF
4153 C old version  PTTCMS(4) = PTSUB(4)/XTSUB
4154                PTTCMS(4) = MAX(PTTCMS(4),PTSUB(4))
4155                XTSUB = PTSUB(4)/PTTCMS(4)
4156                PTOT2 = SQRT((PTTCMS(4)-PHKK(5,MOT))
4157      &                     *(PTTCMS(4)+PHKK(5,MOT)))
4158                DO 4 K=1,3
4159                   PPTCMS(K) = PTOT1*PPSUB(K)/PPSUTO
4160                   PTTCMS(K) = PTOT2*PTSUB(K)/PTSUTO
4161     4          CONTINUE
4162 ***
4163 * testprint
4164 *
4165 *     ppnn  / ptnn   - momenta of the int. nucleons (cms, negl. Fermi)
4166 *     ptotnn         - total momentum of the int. nucleons (cms, negl. Fermi)
4167 *     pptcms/ pttcms - momenta of the interacting nucleons (cms)
4168 *     pp1,2 / pt1,2  - momenta of the four partons
4169 *
4170 *     pp    / pt     - total momenta of the pr/ta partons (cms, negl. Fermi)
4171 *     ptot           - total momentum of the four partons (cms, negl. Fermi)
4172 *     ppsub / ptsub  - total momenta of the proj / targ partons (cms)
4173 *
4174 c              PTOTCM = SQRT( (PPTCMS(1)+PTTCMS(1))**2 +
4175 c    &                        (PPTCMS(2)+PTTCMS(2))**2 +
4176 c    &                        (PPTCMS(3)+PTTCMS(3))**2 )
4177 c              ENEWCM = SQRT( (PPTCMS(4)+PTTCMS(4)-PTOTCM) *
4178 c    &                        (PPTCMS(4)+PTTCMS(4)+PTOTCM) )
4179 c              PTOTSU = SQRT( (PPSUB(1)+PTSUB(1))**2 +
4180 c    &                        (PPSUB(2)+PTSUB(2))**2 +
4181 c    &                        (PPSUB(3)+PTSUB(3))**2 )
4182 c              ENEWSU = SQRT( (PPSUB(4)+PTSUB(4)-PTOTSU) *
4183 c    &                        (PPSUB(4)+PTSUB(4)+PTOTSU) )
4184 c              IF (ENEWCM/EOLDCM.GT.1.1D0) THEN
4185 c                 WRITE(*,*) ' EOLDCM, ENEWCM : ',EOLDCM,ENEWCM
4186 c                 WRITE(*,*) ' EOLDSU, ENEWSU : ',EOLDSU,ENEWSU
4187 c                 WRITE(*,*) ' XPSUB,  XTSUB  : ',XPSUB,XTSUB
4188 c              ENDIF
4189 c              BBGX = (PPTCMS(1)+PTTCMS(1))/ENEWCM
4190 c              BBGY = (PPTCMS(2)+PTTCMS(2))/ENEWCM
4191 c              BBGZ = (PPTCMS(3)+PTTCMS(3))/ENEWCM
4192 c              BGAM = (PPTCMS(4)+PTTCMS(4))/ENEWCM
4193 *     transform interacting nucleons into nucleon-nucleon cm-system
4194 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4195 c    &                    PPTCMS(1),PPTCMS(2),PPTCMS(3),PPTCMS(4),PPTOT,
4196 c    &                     PPNEW1,PPNEW2,PPNEW3,PPNEW4)
4197 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4198 c    &                    PTTCMS(1),PTTCMS(2),PTTCMS(3),PTTCMS(4),PTTOT,
4199 c    &                     PTNEW1,PTNEW2,PTNEW3,PTNEW4)
4200 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4201 c    &                     PPSUB(1),PPSUB(2),PPSUB(3),PPSUB(4),PPTOT,
4202 c    &                     PPSUB1,PPSUB2,PPSUB3,PPSUB4)
4203 c              CALL DT_DALTRA(BGAM,-BBGX,-BBGY,-BBGZ,
4204 c    &                     PTSUB(1),PTSUB(2),PTSUB(3),PTSUB(4),PTTOT,
4205 c    &                     PTSUB1,PTSUB2,PTSUB3,PTSUB4)
4206 c              PTSTCM = SQRT( (PPNEW1+PTNEW1)**2 +
4207 c    &                        (PPNEW2+PTNEW2)**2 +
4208 c    &                        (PPNEW3+PTNEW3)**2 )
4209 c              ETSTCM = SQRT( (PPNEW4+PTNEW4-PTSTCM) *
4210 c    &                        (PPNEW4+PTNEW4+PTSTCM) )
4211 c              PTSTSU = SQRT( (PPSUB1+PTSUB1)**2 +
4212 c    &                        (PPSUB2+PTSUB2)**2 +
4213 c    &                        (PPSUB3+PTSUB3)**2 )
4214 c              ETSTSU = SQRT( (PPSUB4+PTSUB4-PTSTSU) *
4215 c    &                        (PPSUB4+PTSUB4+PTSTSU) )
4216 C              WRITE(*,*) ' mother cmE :'
4217 C              WRITE(*,*) ETSTCM,ENEWCM
4218 C              WRITE(*,*) ' subsystem cmE :'
4219 C              WRITE(*,*) ETSTSU,ENEWSU
4220 C              WRITE(*,*) ' projectile mother :'
4221 C              WRITE(*,*) PPNEW1,PPNEW2,PPNEW3,PPNEW4
4222 C              WRITE(*,*) ' target mother :'
4223 C              WRITE(*,*) PTNEW1,PTNEW2,PTNEW3,PTNEW4
4224 C              WRITE(*,*) ' projectile subsystem:'
4225 C              WRITE(*,*) PPSUB1,PPSUB2,PPSUB3,PPSUB4
4226 C              WRITE(*,*) ' target subsystem:'
4227 C              WRITE(*,*) PTSUB1,PTSUB2,PTSUB3,PTSUB4
4228 C              WRITE(*,*) ' projectile subsystem should be:'
4229 C              WRITE(*,*) ZERO,ZERO,XPSUB*ETSTCM/2.0D0,
4230 C    &                    XPSUB*ETSTCM/2.0D0
4231 C              WRITE(*,*) ' target subsystem should be:'
4232 C              WRITE(*,*) ZERO,ZERO,-XTSUB*ETSTCM/2.0D0,
4233 C    &                    XTSUB*ETSTCM/2.0D0
4234 C              WRITE(*,*) ' subsystem cmE should be: '
4235 C              WRITE(*,*) SQRT(XPSUB*XTSUB)*ETSTCM,XPSUB,XTSUB
4236 ***
4237 *
4238 *     generate complete remnant - nucleon/remnant event with PHOJET
4239
4240                CALL PHO_EVENT(3,PPTCMS,PTTCMS,DUM,IREJ1)
4241
4242 *
4243 *     copy back original settings of PHOJET process flags
4244                DO 11 K=1,11
4245                   IPRON(K,1) = KPRON(K)
4246    11          CONTINUE
4247 *
4248 *     check if PHOJET has rejected this event
4249                IF (IREJ1.NE.0) THEN
4250                   IF (IOULEV(1).GT.0)
4251      &            WRITE(LOUT,'(1X,A)') 'EVENTB:  chain system rejected'
4252                   WRITE(LOUT,*)
4253      &                 'XPSUB,XTSUB,SECM ',XPSUB,XTSUB,SECM,AMTOT
4254
4255                   CALL PHO_PREVNT(0)
4256
4257                   GOTO 9999
4258                ENDIF
4259 *
4260 *     copy partons and strings from PHOJET common back into DTEVT for
4261 *     external fragmentation
4262                MO1 = NC
4263                MO2 = NC+3
4264 *!      uncomment this line for internal phojet-fragmentation
4265 C              CALL DT_GETFSP(MO1,MO2,PP,PT,1)
4266                NPHOSC = NPHOSC+1
4267                CALL DT_GETPJE(MO1,MO2,PP,PT,1,NPHOSC,IREJ1)
4268                IF (IREJ1.NE.0) THEN
4269                   IF (IOULEV(1).GT.0) WRITE(LOUT,'(1X,A,I4)')
4270      &               'EVENTB: chain system rejected 2'
4271                   GOTO 9999
4272                ENDIF
4273 *
4274 *     update statistics counter
4275                ICEVTG(IDCH(NC),2) = ICEVTG(IDCH(NC),2)+1
4276 *
4277 *-----------------------------------------------------------------------
4278 * two-chain approx. for smaller systems
4279 *
4280             ELSE
4281 *
4282                NDTUSC = NDTUSC+1
4283 *   special flag for double-Pomeron statistics
4284                IPOPO = 0
4285 *
4286 *   pick up flavors at the ends of the two chains
4287                IFP1 = IDHKK(NC)
4288                IFT1 = IDHKK(NC+1)
4289                IFP2 = IDHKK(NC+2)
4290                IFT2 = IDHKK(NC+3)
4291 *   ..and the indices of the mothers
4292                MOP1 = NC
4293                MOT1 = NC+1
4294                MOP2 = NC+2
4295                MOT2 = NC+3
4296                CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
4297      &                     IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
4298 *
4299 *   check if this chain system was rejected
4300                IF (IREJ1.GT.0) THEN
4301                   IF (IOULEV(1).GT.0) THEN
4302                      WRITE(LOUT,*) 'rejected 1 in EVENTB'
4303                      WRITE(LOUT,'(1X,4(I6,4E12.3,/),E12.3)')
4304      &                  IFP1,PP1,IFT1,PT1,IFP2,PP2,IFT2,PT2,AMTOT
4305                   ENDIF
4306                   IRHHA = IRHHA+1
4307                   GOTO 9999
4308                ENDIF
4309 *   the following lines are for sea-sea chains rejected in GETCSY
4310                IF (IREJ1.EQ.-1) NDTUSC = NDTUSC-1
4311                ICEVTG(IDCH(NC),1) = ICEVTG(IDCH(NC),1)+1
4312             ENDIF
4313 *
4314          ENDIF
4315 *
4316 *     update statistics counter
4317          ICEVTG(IDCH(NC),0) = ICEVTG(IDCH(NC),0)+1
4318 *
4319          NC = NC+4
4320 *
4321     2 CONTINUE
4322 *
4323 *-----------------------------------------------------------------------
4324 * treatment of low-mass chains (if there are any)
4325 *
4326       IF (NDTUSC.GT.0) THEN
4327 *
4328 *   correct chains of very low masses for possible resonances
4329          IF (IRESCO.EQ.1) THEN
4330             CALL DT_EVTRES(IREJ1)
4331             IF (IREJ1.GT.0) THEN
4332                IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2a in EVENTB'
4333                IRRES(1) = IRRES(1)+1
4334                GOTO 9999
4335             ENDIF
4336          ENDIF
4337 *   fragmentation of low-mass chains
4338 *!  uncomment this line for internal phojet-fragmentation
4339 *   (of course it will still be fragmented by DPMJET-routines but it
4340 *    has to be done here instead of further below)
4341 C        CALL DT_EVTFRA(IREJ1)
4342 C        IF (IREJ1.GT.0) THEN
4343 C           IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2b in EVENTB'
4344 C           IRFRAG = IRFRAG+1
4345 C           GOTO 9999
4346 C        ENDIF
4347       ELSE
4348 *! uncomment this line for internal phojet-fragmentation
4349 C        NPOINT(4) = NHKK+1
4350          IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
4351       ENDIF
4352 *
4353 *-----------------------------------------------------------------------
4354 * new di-quark breaking mechanisms
4355 *
4356       MXLEFT = 2
4357       CALL DT_CHASTA(0)
4358       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
4359      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
4360          CALL DT_DIQBRK
4361          MXLEFT = 4
4362       ENDIF
4363 *
4364 *-----------------------------------------------------------------------
4365 * hadronize this event
4366 *
4367 *   hadronize PHOJET chain systems
4368       NPYMAX = 0
4369       NPJE   = NPHOSC/MXPHFR
4370       IF (MXPHFR.LT.MXLEFT) MXLEFT = 2
4371       IF (NPJE.GT.1) THEN
4372          NLEFT = NPHOSC-NPJE*MXPHFR
4373          DO 20 JFRG=1,NPJE
4374             NFRG = JFRG*MXPHFR
4375             IF ((JFRG.EQ.NPJE).AND.(NLEFT.LE.MXLEFT)) THEN
4376                CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4377                IF (IREJ1.GT.0) GOTO 22
4378                NLEFT = 0
4379             ELSE
4380                CALL DT_EVTFRG(1,NFRG,NPYMEM,IREJ1)
4381                IF (IREJ1.GT.0) GOTO 22
4382             ENDIF
4383             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4384    20    CONTINUE
4385          IF (NLEFT.GT.0) THEN
4386             CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4387             IF (IREJ1.GT.0) GOTO 22
4388             IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4389          ENDIF
4390       ELSE
4391          CALL DT_EVTFRG(1,NPHOSC,NPYMEM,IREJ1)
4392          IF (IREJ1.GT.0) GOTO 22
4393          IF (NPYMEM.GT.NPYMAX) NPYMAX = NPYMEM
4394       ENDIF
4395 *
4396 *   check max. filling level of jetset common and
4397 *   reduce mxphfr if necessary
4398       IF (NPYMAX.GT.3000) THEN
4399          IF (NPYMAX.GT.3500) THEN
4400             MXPHFR = MAX(1,MXPHFR-2)
4401          ELSE
4402             MXPHFR = MAX(1,MXPHFR-1)
4403          ENDIF
4404 C        WRITE(LOUT,*) ' EVENTB: Mxphfr reduced to ',MXPHFR
4405       ENDIF
4406 *
4407 *   hadronize DTUNUC chain systems
4408    23 CONTINUE
4409       IBACK = MXDTFR
4410       CALL DT_EVTFRG(2,IBACK,NPYMEM,IREJ2)
4411       IF (IREJ2.GT.0) GOTO 22
4412 *
4413 *   check max. filling level of jetset common and
4414 *   reduce mxdtfr if necessary
4415       IF (NPYMEM.GT.3000) THEN
4416          IF (NPYMEM.GT.3500) THEN
4417             MXDTFR = MAX(1,MXDTFR-20)
4418          ELSE
4419             MXDTFR = MAX(1,MXDTFR-10)
4420          ENDIF
4421 C        WRITE(LOUT,*) ' EVENTB: Mxdtfr reduced to ',MXDTFR
4422       ENDIF
4423 *
4424       IF (IBACK.EQ.-1) GOTO 23
4425 *
4426    22 CONTINUE
4427 C     CALL DT_EVTFRG(1,IREJ1)
4428 C     CALL DT_EVTFRG(2,IREJ2)
4429       IF ((IREJ1.GT.0).OR.(IREJ2.GT.0)) THEN
4430          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTB'
4431          IRFRAG = IRFRAG+1
4432          GOTO 9999
4433       ENDIF
4434 *
4435 * get final state particles from /DTEVTP/
4436 *! uncomment this line for internal phojet-fragmentation
4437 C     CALL DT_GETFSP(IDUM,IDUM,PP,PT,2)
4438
4439       IF (IJPROJ.NE.7)
4440      &   CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,88,IREJ3)
4441 C     IF (IREJ3.NE.0) GOTO 9999
4442
4443       RETURN
4444
4445  9999 CONTINUE
4446       IREVT = IREVT+1
4447       IREJ  = 1
4448       RETURN
4449       END
4450
4451 *$ CREATE DT_GETPJE.FOR
4452 *COPY DT_GETPJE
4453 *
4454 *===getpje=============================================================*
4455 *
4456       SUBROUTINE DT_GETPJE(MO1,MO2,PP,PT,MODE,IPJE,IREJ)
4457
4458 ************************************************************************
4459 * This subroutine copies PHOJET partons and strings from POEVT1 into   *
4460 * DTEVT1.                                                              *
4461 *      MO1,MO2   indices of first and last mother-parton in DTEVT1     *
4462 *      PP,PT     4-momenta of projectile/target being handled by       *
4463 *                PHOJET                                                *
4464 * This version dated 11.12.99 is written by S. Roesler                 *
4465 ************************************************************************
4466
4467       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4468       SAVE
4469
4470       PARAMETER ( LINP = 10 ,
4471      &            LOUT = 6 ,
4472      &            LDAT = 9 )
4473
4474       PARAMETER (TINY10=1.0D-10,TINY1=1.0D-1,
4475      &           ZERO=0.0D0,ONE=1.0D0,OHALF=0.5D0)
4476
4477       LOGICAL LFLIP
4478
4479 * event history
4480
4481       PARAMETER (NMXHKK=200000)
4482
4483       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
4484      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
4485      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
4486
4487 * extended event history
4488       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
4489      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
4490      &                IHIST(2,NMXHKK)
4491
4492 * Lorentz-parameters of the current interaction
4493       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4494      &                UMO,PPCM,EPROJ,PPROJ
4495
4496 * DTUNUC-PHOJET interface, Lorentz-param. of n-n subsystem
4497       COMMON /DTLTSU/ BGX,BGY,BGZ,GAM
4498
4499 * flags for input different options
4500       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
4501       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
4502      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
4503
4504 * statistics: double-Pomeron exchange
4505       COMMON /DTFLG2/ INTFLG,IPOPO
4506
4507 * statistics
4508       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
4509      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
4510      &                ICEVTG(8,0:30)
4511
4512 * rejection counter
4513       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
4514      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
4515      &                IREXCI(3),IRDIFF(2),IRINC
4516 C  standard particle data interface
4517       INTEGER NMXHEP
4518
4519       PARAMETER (NMXHEP=4000)
4520
4521       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
4522       DOUBLE PRECISION PHEP,VHEP
4523       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
4524      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
4525      &                VHEP(4,NMXHEP)
4526 C  extension to standard particle data interface (PHOJET specific)
4527       INTEGER IMPART,IPHIST,ICOLOR
4528       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
4529
4530 C  color string configurations including collapsed strings and hadrons
4531       INTEGER MSTR
4532       PARAMETER (MSTR=500)
4533       INTEGER NPOS,NCODE,IPAR1,IPAR2,IPAR3,IPAR4,NNCH,IBHAD
4534       COMMON /POSTRG/ NPOS(4,MSTR),NCODE(MSTR),
4535      &                IPAR1(MSTR),IPAR2(MSTR),IPAR3(MSTR),IPAR4(MSTR),
4536      &                NNCH(MSTR),IBHAD(MSTR),ISTR
4537
4538 C  general process information
4539       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
4540       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
4541
4542 C  model switches and parameters
4543       CHARACTER*8 MDLNA
4544       INTEGER ISWMDL,IPAMDL
4545       DOUBLE PRECISION PARMDL
4546       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
4547
4548 C  event debugging information
4549       INTEGER NMAXD
4550       PARAMETER (NMAXD=100)
4551       INTEGER IDEB,KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,KHTRG,KSLOO,
4552      &        KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4553       COMMON /PODEBG/ IDEB(NMAXD),KSPOM,KHPOM,KSREG,KHDIR,KACCEP,KSTRG,
4554      &                KHTRG,KSLOO,KHLOO,KSDPO,KHDPO,KEVENT,KSOFT,KHARD
4555
4556       DIMENSION PP(4),PT(4)
4557       DATA MAXLOP /10000/
4558
4559       INHKK = NHKK
4560       LFLIP = .TRUE.
4561     1 CONTINUE
4562       NPVAL = 0
4563       NTVAL = 0
4564       IREJ  = 0
4565
4566 *   store initial momenta for energy-momentum conservation check
4567       IF (LEMCCK) THEN
4568          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM1,IDUM2)
4569          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM1,IDUM2)
4570       ENDIF
4571 * copy partons and strings from POEVT1 into DTEVT1
4572       DO 11 I=1,ISTR
4573 C        IF ((NCODE(I).EQ.-99).AND.(IPAMDL(17).EQ.0)) THEN
4574          IF (NCODE(I).EQ.-99) THEN
4575             IDXSTG = NPOS(1,I)
4576             IDSTG  = IDHEP(IDXSTG)
4577             PX = PHEP(1,IDXSTG)
4578             PY = PHEP(2,IDXSTG)
4579             PZ = PHEP(3,IDXSTG)
4580             PE = PHEP(4,IDXSTG)
4581             IF (MODE.LT.0) THEN
4582                ISTAT = 70000+IPJE
4583                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PX,PY,PZ,PE,
4584      &                        11,IDSTG,0)
4585                IF (LEMCCK) THEN
4586                   PX = -PX
4587                   PY = -PY
4588                   PZ = -PZ
4589                   PE = -PE
4590                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4591                ENDIF
4592             ELSE
4593                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4594      &                        PPX,PPY,PPZ,PPE)
4595                ISTAT = 70000+IPJE
4596                CALL DT_EVTPUT(2,ISTAT,MO1,MO2,PPX,PPY,PPZ,PPE,
4597      &                        11,IDSTG,0)
4598                IF (LEMCCK) THEN
4599                   PX = -PPX
4600                   PY = -PPY
4601                   PZ = -PPZ
4602                   PE = -PPE
4603                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4604                ENDIF
4605             ENDIF
4606             NOBAM(NHKK)   = 0
4607             IHIST(1,NHKK) = IPHIST(1,IDXSTG)
4608             IHIST(2,NHKK) = 0
4609          ELSEIF (NCODE(I).GE.0) THEN
4610 *   indices of partons and string in POEVT1
4611             IDX1 = ABS(JMOHEP(1,NPOS(1,I)))
4612             IDX2 = ABS(JMOHEP(2,NPOS(1,I)))
4613             IF ((IDX1.GT.IDX2).OR.(JMOHEP(2,NPOS(1,I)).GT.0)) THEN
4614                WRITE(LOUT,*) ' GETPJE: IDX1.GT.IDX2 ',IDX1,IDX2,
4615      &         ' or JMOHEP(2,NPOS(1,I)).GT.0 ',JMOHEP(2,NPOS(1,I)),' ! '
4616                STOP ' GETPJE 1'
4617             ENDIF
4618             IDXSTG = NPOS(1,I)
4619 *   find "mother" string of the string
4620             IDXMS1 = ABS(JMOHEP(1,IDX1))
4621             IDXMS2 = ABS(JMOHEP(1,IDX2))
4622             IF (IDXMS1.NE.IDXMS2) THEN
4623                IDXMS1 = IDXSTG
4624                IDXMS2 = IDXSTG
4625 C              STOP ' GETPJE: IDXMS1.NE.IDXMS2 !'
4626             ENDIF
4627 *   search POEVT1 for the original hadron of the parton
4628             ILOOP = 0
4629             IPOM1 = 0
4630    14       CONTINUE
4631             ILOOP = ILOOP+1
4632
4633             IF (IDHEP(IDXMS1).EQ.990) IPOM1 = 1
4634
4635             IDXMS1 = ABS(JMOHEP(1,IDXMS1))
4636             IF ((IDXMS1.NE.1).AND.(IDXMS1.NE.2).AND.
4637      &          (ILOOP.LT.MAXLOP)) GOTO 14
4638             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 1 ! '
4639             IPOM2 = 0
4640             ILOOP = 0
4641    15       CONTINUE
4642             ILOOP = ILOOP+1
4643
4644             IF (IDHEP(IDXMS2).EQ.990) IPOM2 = 1
4645
4646             IF ((ILOOP.EQ.1).OR.(IDHEP(IDXMS2).GE.7777)) THEN
4647                IDXMS2 = ABS(JMOHEP(2,IDXMS2))
4648             ELSE
4649                IDXMS2 = ABS(JMOHEP(1,IDXMS2))
4650             ENDIF
4651             IF ((IDXMS2.NE.1).AND.(IDXMS2.NE.2).AND.
4652      &          (ILOOP.LT.MAXLOP)) GOTO 15
4653             IF (ILOOP.EQ.MAXLOP) WRITE(LOUT,*) ' GETPJE: MAXLOP in 5 ! '
4654 *   parton 1
4655             IF (IDXMS1.EQ.1) THEN
4656                ISPTN1 = ISTHKK(MO1)
4657                M1PTN1 = MO1
4658                M2PTN1 = MO1+2
4659             ELSE
4660                ISPTN1 = ISTHKK(MO2)
4661                M1PTN1 = MO2-2
4662                M2PTN1 = MO2
4663             ENDIF
4664 *   parton 2
4665             IF (IDXMS2.EQ.1) THEN
4666                ISPTN2 = ISTHKK(MO1)
4667                M1PTN2 = MO1
4668                M2PTN2 = MO1+2
4669             ELSE
4670                ISPTN2 = ISTHKK(MO2)
4671                M1PTN2 = MO2-2
4672                M2PTN2 = MO2
4673             ENDIF
4674 *   check for mis-identified mothers and switch mother indices if necessary
4675             IF ((IDXMS1.EQ.IDXMS2).AND.(IPROCE.NE.5).AND.(IPROCE.NE.6)
4676      &          .AND.((IDHEP(IDX1).NE.21).OR.(IDHEP(IDX2).NE.21)).AND.
4677      &          (LFLIP)) THEN
4678                IF (PHEP(3,IDX1).GT.PHEP(3,IDX2)) THEN
4679                   ISPTN1 = ISTHKK(MO1)
4680                   M1PTN1 = MO1
4681                   M2PTN1 = MO1+2
4682                   ISPTN2 = ISTHKK(MO2)
4683                   M1PTN2 = MO2-2
4684                   M2PTN2 = MO2
4685                ELSE
4686                   ISPTN1 = ISTHKK(MO2)
4687                   M1PTN1 = MO2-2
4688                   M2PTN1 = MO2
4689                   ISPTN2 = ISTHKK(MO1)
4690                   M1PTN2 = MO1
4691                   M2PTN2 = MO1+2
4692                ENDIF
4693             ENDIF
4694 *   register partons in temporary common
4695 *     parton at chain end
4696             PX = PHEP(1,IDX1)
4697             PY = PHEP(2,IDX1)
4698             PZ = PHEP(3,IDX1)
4699             PE = PHEP(4,IDX1)
4700 * flag only partons coming from Pomeron with 41/42
4701 C           IF ((IPOM1.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4702             IF (IPOM1.NE.0) THEN
4703                ISTX = ABS(ISPTN1)/10
4704                IMO  = ABS(ISPTN1)-10*ISTX
4705                ISPTN1 = -(40+IMO)
4706             ELSE
4707                IF ((ICOLOR(2,IDX1).EQ.0).OR.(IDHEP(IDX1).EQ.21)) THEN
4708                   ISTX = ABS(ISPTN1)/10
4709                   IMO  = ABS(ISPTN1)-10*ISTX
4710                   IF ((IDHEP(IDX1).EQ.21).OR.
4711      &                (ABS(IPHIST(1,IDX1)).GE.100)) THEN
4712                      ISPTN1 = -(60+IMO)
4713                   ELSE
4714                      ISPTN1 = -(50+IMO)
4715                   ENDIF
4716                ENDIF
4717             ENDIF
4718             IF (ISPTN1.EQ.-21) NPVAL = NPVAL+1
4719             IF (ISPTN1.EQ.-22) NTVAL = NTVAL+1
4720             IF (MODE.LT.0) THEN
4721                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PX,PY,
4722      &                        PZ,PE,0,0,0)
4723             ELSE
4724                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4725      &                        PPX,PPY,PPZ,PPE)
4726                CALL DT_EVTPUT(ISPTN1,IDHEP(IDX1),M1PTN1,M2PTN1,PPX,PPY,
4727      &                        PPZ,PPE,0,0,0)
4728             ENDIF
4729             IHIST(1,NHKK) = IPHIST(1,IDX1)
4730             IHIST(2,NHKK) = 0
4731             DO 19 KK=1,4
4732                VHKK(KK,NHKK) = VHKK(KK,M2PTN1)
4733                WHKK(KK,NHKK) = WHKK(KK,M1PTN1)
4734    19       CONTINUE
4735             VHKK(4,NHKK) = VHKK(3,M2PTN1)/BLAB-VHKK(3,M1PTN1)/BGLAB
4736             WHKK(4,NHKK) = -WHKK(3,M1PTN1)/BLAB+WHKK(3,M2PTN1)/BGLAB
4737             M1STRG = NHKK
4738 *     gluon kinks
4739             NGLUON = IDX2-IDX1-1
4740             IF (NGLUON.GT.0) THEN
4741                DO 17 IGLUON=1,NGLUON
4742                   IDX   = IDX1+IGLUON
4743                   IDXMS = ABS(JMOHEP(1,IDX))
4744                   IF ((IDXMS.NE.1).AND.(IDXMS.NE.2)) THEN
4745                      ILOOP = 0
4746    16                CONTINUE
4747                      ILOOP = ILOOP+1
4748                      IDXMS = ABS(JMOHEP(1,IDXMS))
4749                      IF ((IDXMS.NE.1).AND.(IDXMS.NE.2).AND.
4750      &                   (ILOOP.LT.MAXLOP)) GOTO 16
4751                      IF (ILOOP.EQ.MAXLOP)
4752      &                  WRITE(LOUT,*) ' GETPJE: MAXLOP in 3 ! '
4753                   ENDIF
4754                   IF (IDXMS.EQ.1) THEN
4755                      ISPTN = ISTHKK(MO1)
4756                      M1PTN = MO1
4757                      M2PTN = MO1+2
4758                   ELSE
4759                      ISPTN = ISTHKK(MO2)
4760                      M1PTN = MO2-2
4761                      M2PTN = MO2
4762                   ENDIF
4763                   PX = PHEP(1,IDX)
4764                   PY = PHEP(2,IDX)
4765                   PZ = PHEP(3,IDX)
4766                   PE = PHEP(4,IDX)
4767                   IF ((ICOLOR(2,IDX).EQ.0).OR.(IDHEP(IDX).EQ.21)) THEN
4768                      ISTX = ABS(ISPTN)/10
4769                      IMO  = ABS(ISPTN)-10*ISTX
4770                      IF ((IDHEP(IDX).EQ.21).OR.
4771      &                   (ABS(IPHIST(1,IDX)).GE.100)) THEN
4772                         ISPTN = -(60+IMO)
4773                      ELSE
4774                         ISPTN = -(50+IMO)
4775                      ENDIF
4776                   ENDIF
4777                   IF (ISPTN.EQ.-21) NPVAL = NPVAL+1
4778                   IF (ISPTN.EQ.-22) NTVAL = NTVAL+1
4779                   IF (MODE.LT.0) THEN
4780                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4781      &                              PX,PY,PZ,PE,0,0,0)
4782                   ELSE
4783                      CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4784      &                              PPX,PPY,PPZ,PPE)
4785                      CALL DT_EVTPUT(ISPTN,IDHEP(IDX),M1PTN,M2PTN,
4786      &                              PPX,PPY,PPZ,PPE,0,0,0)
4787                   ENDIF
4788                   IHIST(1,NHKK) = IPHIST(1,IDX)
4789                   IHIST(2,NHKK) = 0
4790                   DO 20 KK=1,4
4791                      VHKK(KK,NHKK) = VHKK(KK,M2PTN)
4792                      WHKK(KK,NHKK) = WHKK(KK,M1PTN)
4793    20             CONTINUE
4794                   VHKK(4,NHKK)= VHKK(3,M2PTN)/BLAB-VHKK(3,M1PTN)/BGLAB
4795                   WHKK(4,NHKK)= -WHKK(3,M1PTN)/BLAB+WHKK(3,M2PTN)/BGLAB
4796    17          CONTINUE
4797             ENDIF
4798 *     parton at chain end
4799             PX = PHEP(1,IDX2)
4800             PY = PHEP(2,IDX2)
4801             PZ = PHEP(3,IDX2)
4802             PE = PHEP(4,IDX2)
4803 * flag only partons coming from Pomeron with 41/42
4804 C           IF ((IPOM2.NE.0).OR.(NPOS(4,I).GE.4)) THEN
4805             IF (IPOM2.NE.0) THEN
4806                ISTX = ABS(ISPTN2)/10
4807                IMO  = ABS(ISPTN2)-10*ISTX
4808                ISPTN2 = -(40+IMO)
4809             ELSE
4810                IF ((ICOLOR(2,IDX2).EQ.0).OR.(IDHEP(IDX2).EQ.21)) THEN
4811                   ISTX = ABS(ISPTN2)/10
4812                   IMO  = ABS(ISPTN2)-10*ISTX
4813                   IF ((IDHEP(IDX2).EQ.21).OR.
4814      &                (ABS(IPHIST(1,IDX2)).GE.100)) THEN
4815                      ISPTN2 = -(60+IMO)
4816                   ELSE
4817                      ISPTN2 = -(50+IMO)
4818                   ENDIF
4819                ENDIF
4820             ENDIF
4821             IF (ISPTN2.EQ.-21) NPVAL = NPVAL+1
4822             IF (ISPTN2.EQ.-22) NTVAL = NTVAL+1
4823             IF (MODE.LT.0) THEN
4824                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4825      &                        PX,PY,PZ,PE,0,0,0)
4826             ELSE
4827                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4828      &                        PPX,PPY,PPZ,PPE)
4829                CALL DT_EVTPUT(ISPTN2,IDHEP(IDX2),M1PTN2,M2PTN2,
4830      &                        PPX,PPY,PPZ,PPE,0,0,0)
4831             ENDIF
4832             IHIST(1,NHKK) = IPHIST(1,IDX2)
4833             IHIST(2,NHKK) = 0
4834             DO 21 KK=1,4
4835                VHKK(KK,NHKK) = VHKK(KK,M2PTN2)
4836                WHKK(KK,NHKK) = WHKK(KK,M1PTN2)
4837    21       CONTINUE
4838             VHKK(4,NHKK) = VHKK(3,M2PTN2)/BLAB-VHKK(3,M1PTN2)/BGLAB
4839             WHKK(4,NHKK) = -WHKK(3,M1PTN2)/BLAB+WHKK(3,M2PTN2)/BGLAB
4840             M2STRG = NHKK
4841 *   register string
4842             JSTRG = 100*IPROCE+NCODE(I)
4843             PX = PHEP(1,IDXSTG)
4844             PY = PHEP(2,IDXSTG)
4845             PZ = PHEP(3,IDXSTG)
4846             PE = PHEP(4,IDXSTG)
4847             IF (MODE.LT.0) THEN
4848                ISTAT = 70000+IPJE
4849                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4850      &                        PX,PY,PZ,PE,0,0,0)
4851                IF (LEMCCK) THEN
4852                   PX = -PX
4853                   PY = -PY
4854                   PZ = -PZ
4855                   PE = -PE
4856                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4857                ENDIF
4858             ELSE
4859                CALL DT_DALTRA(GAM,BGX,BGY,BGZ,PX,PY,PZ,PE,PTOTMP,
4860      &                        PPX,PPY,PPZ,PPE)
4861                ISTAT = 70000+IPJE
4862                CALL DT_EVTPUT(JSTRG,ISTAT,M1STRG,M2STRG,
4863      &                        PPX,PPY,PPZ,PPE,0,0,0)
4864                IF (LEMCCK) THEN
4865                   PX = -PPX
4866                   PY = -PPY
4867                   PZ = -PPZ
4868                   PE = -PPE
4869                   CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
4870                ENDIF
4871             ENDIF
4872             NOBAM(NHKK)   = 0
4873             IHIST(1,NHKK) = 0
4874             IHIST(2,NHKK) = 0
4875             DO 18 KK=1,4
4876                VHKK(KK,NHKK) = VHKK(KK,MO2)
4877                WHKK(KK,NHKK) = WHKK(KK,MO1)
4878    18       CONTINUE
4879             VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
4880             WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
4881          ENDIF
4882    11 CONTINUE
4883
4884       IF ( ((NPVAL.GT.2).OR.(NTVAL.GT.2)).AND.(LFLIP) ) THEN
4885          NHKK  = INHKK
4886          LFLIP = .FALSE.
4887          GOTO 1
4888       ENDIF
4889
4890       IF (LEMCCK) THEN
4891          IF (UMO.GT.1.0D5) THEN
4892             CHKLEV = 1.0D0
4893          ELSE
4894             CHKLEV = TINY1
4895          ENDIF
4896          CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,1000,IREJ2)
4897
4898          IF (IREJ2.GT.ZERO) CALL PHO_PREVNT(0)
4899
4900       ENDIF
4901
4902 * internal statistics
4903 *   dble-Po statistics.
4904       IF (IPROCE.NE.4) IPOPO = 0
4905
4906       INTFLG = IPROCE
4907       IDCHSY = IDCH(MO1)
4908       IF ((IPROCE.GE.1).AND.(IPROCE.LE.8)) THEN
4909          ICEVTG(IDCHSY,IPROCE+2) = ICEVTG(IDCHSY,IPROCE+2)+1
4910       ELSE
4911          WRITE(LOUT,1000) IPROCE,NEVHKK,MO1
4912  1000    FORMAT(1X,'GETFSP:   warning! incons. process id. (',I2,
4913      &          ') at evt(chain) ',I6,'(',I2,')')
4914       ENDIF
4915       IF (IPROCE.EQ.5) THEN
4916          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3)) THEN
4917             ICEVTG(IDCHSY,18+IDIFR1) = ICEVTG(IDCHSY,18+IDIFR1)+1
4918          ELSE
4919 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4920  1001       FORMAT(1X,'GETFSP:   warning! incons. diffrac. id. ',
4921      &             '(IPROCE,IDIFR1,IDIFR2=',3I3,')')
4922          ENDIF
4923       ELSEIF (IPROCE.EQ.6) THEN
4924          IF ((IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4925             ICEVTG(IDCHSY,21+IDIFR2) = ICEVTG(IDCHSY,21+IDIFR2)+1
4926          ELSE
4927 C           WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4928          ENDIF
4929       ELSEIF (IPROCE.EQ.7) THEN
4930          IF ((IDIFR1.GE.1).AND.(IDIFR1.LE.3).AND.
4931      &       (IDIFR2.GE.1).AND.(IDIFR2.LE.3)) THEN
4932             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.1))
4933      &         ICEVTG(IDCHSY,25) = ICEVTG(IDCHSY,25)+1
4934             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.2))
4935      &         ICEVTG(IDCHSY,26) = ICEVTG(IDCHSY,26)+1
4936             IF ((IDIFR1.EQ.1).AND.(IDIFR2.EQ.2))
4937      &         ICEVTG(IDCHSY,27) = ICEVTG(IDCHSY,27)+1
4938             IF ((IDIFR1.EQ.2).AND.(IDIFR2.EQ.1))
4939      &         ICEVTG(IDCHSY,28) = ICEVTG(IDCHSY,28)+1
4940          ELSE
4941             WRITE(LOUT,1001) IPROCE,IDIFR1,IDIFR2
4942          ENDIF
4943       ENDIF
4944       IF ((IDIFR1+IDIFR2.EQ.0).AND.(KHDIR.GE.1).AND.(KHDIR.LE.3))
4945      &                                                       THEN
4946          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4947          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4948          ICEVTG(IDCHSY,10+KHDIR) = ICEVTG(IDCHSY,10+KHDIR)+1
4949       ENDIF
4950       ICEVTG(IDCHSY,14) = ICEVTG(IDCHSY,14)+KSPOM
4951       ICEVTG(IDCHSY,15) = ICEVTG(IDCHSY,15)+KHPOM
4952       ICEVTG(IDCHSY,16) = ICEVTG(IDCHSY,16)+KSREG
4953       ICEVTG(IDCHSY,17) = ICEVTG(IDCHSY,17)+(KSTRG+KHTRG)
4954       ICEVTG(IDCHSY,18) = ICEVTG(IDCHSY,18)+(KSLOO+KHLOO)
4955
4956       RETURN
4957
4958  9999 CONTINUE
4959       IREJ = 1
4960       RETURN
4961       END
4962
4963 *$ CREATE DT_PHOINI.FOR
4964 *COPY DT_PHOINI
4965 *
4966 *===phoini=============================================================*
4967 *
4968       SUBROUTINE DT_PHOINI
4969
4970 ************************************************************************
4971 * Initialization PHOJET-event generator for nucleon-nucleon interact.  *
4972 * This version dated 16.11.95 is written by S. Roesler                 *
4973 *                                                                      *
4974 * Last change 27.12.2006 by S. Roesler.                                *
4975 ************************************************************************
4976
4977       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
4978       SAVE
4979
4980       PARAMETER ( LINP = 10 ,
4981      &            LOUT = 6 ,
4982      &            LDAT = 9 )
4983
4984       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,ONE=1.0D0)
4985
4986 * nucleon-nucleon event-generator
4987       CHARACTER*8 CMODEL
4988       LOGICAL LPHOIN
4989       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
4990
4991 * particle properties (BAMJET index convention)
4992       CHARACTER*8  ANAME
4993       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
4994      &                IICH(210),IIBAR(210),K1(210),K2(210)
4995
4996 * Lorentz-parameters of the current interaction
4997       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
4998      &                UMO,PPCM,EPROJ,PPROJ
4999
5000 * properties of interacting particles
5001       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5002
5003 * properties of photon/lepton projectiles
5004       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5005
5006       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
5007
5008 * emulsion treatment
5009       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
5010      &                NCOMPO,IEMUL
5011
5012 * VDM parameter for photon-nucleus interactions
5013       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
5014
5015 * nuclear potential
5016       LOGICAL LFERMI
5017       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5018      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5019      &                ETACOU(2),ICOUL,LFERMI
5020
5021 * Glauber formalism: flags and parameters for statistics
5022       LOGICAL LPROD
5023       CHARACTER*8 CGLB
5024       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
5025 *
5026 * parameters for cascade calculations:
5027 * maximum mumber of PDF's which can be defined in phojet (limited
5028 * by the dimension of ipdfs in pho_setpdf)
5029       PARAMETER (MAXPDF = 20)
5030 * PDF parametrization and number of set for the first 30 hadrons in
5031 * the bamjet-code list
5032 *   negative numbers mean that the PDF is set in phojet,
5033 *   zero stands for "not a hadron"
5034       DIMENSION IPARPD(30),ISETPD(30)
5035 * PDF parametrization
5036       DATA IPARPD /
5037      &  -5,-5, 0, 0, 0, 0,-5,-5,-5, 0, 0, 5,-5,-5, 5, 5, 5, 5, 5, 5,
5038      &   5, 5,-5, 5, 5, 0, 0, 0, 0, 0/
5039 * number of set
5040       DATA ISETPD /
5041      &  -6,-6, 0, 0, 0, 0,-3,-6,-6, 0, 0, 2,-2,-2, 2, 2, 6, 6, 2, 6,
5042      &   6, 6,-2, 2, 2, 0, 0, 0, 0, 0/
5043
5044 **PHOJET105a
5045 C     COMMON /GLOCMS/ XECM,XPCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
5046 C     PARAMETER ( MAXPRO = 16 )
5047 C     PARAMETER ( MAXTAB = 20 )
5048 C     COMMON /HAXSEC/ XSECTA(4,-1:MAXPRO,4,MAXTAB),XSECT(6,-1:MAXPRO),
5049 C    &                MXSECT(0:4,-1:MAXPRO,4),ECMSH(4,MAXTAB),ISTTAB
5050 C     CHARACTER*8 MDLNA
5051 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
5052 C     COMMON /PROCES/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15)
5053 **PHOJET110
5054
5055 C  global event kinematics and particle IDs
5056       INTEGER IFPAP,IFPAB
5057       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
5058       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
5059
5060 C  hard cross sections and MC selection weights
5061       INTEGER Max_pro_2
5062       PARAMETER ( Max_pro_2 = 16 )
5063       INTEGER IHa_last,IHb_last,MH_pro_on,MH_tried,
5064      &  MH_acc_1,MH_acc_2
5065       DOUBLE PRECISION Hfac,HWgx,HSig,Hdpt,HEcm_last,HQ2a_last,HQ2b_last
5066       COMMON /POHRCS/ Hfac(-1:Max_pro_2),HWgx(-1:Max_pro_2),
5067      &  HSig(-1:Max_pro_2),Hdpt(-1:Max_pro_2),
5068      &  HEcm_last,HQ2a_last,HQ2b_last,IHa_last,IHb_last,
5069      &  MH_pro_on(-1:Max_pro_2,0:4),MH_tried(-1:Max_pro_2,0:4),
5070      &  MH_acc_1(-1:Max_pro_2,0:4),MH_acc_2(-1:Max_pro_2,0:4)
5071
5072 C  model switches and parameters
5073       CHARACTER*8 MDLNA
5074       INTEGER ISWMDL,IPAMDL
5075       DOUBLE PRECISION PARMDL
5076       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
5077
5078 C  general process information
5079       INTEGER IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON
5080       COMMON /POPRCS/ IPROCE,IDNODF,IDIFR1,IDIFR2,IDDPOM,IPRON(15,4)
5081 **
5082       DIMENSION PP(4),PT(4)
5083
5084       LOGICAL LSTART
5085       DATA LSTART /.TRUE./
5086
5087       IJP = IJPROJ
5088       IJT = IJTARG
5089       Q2  = VIRT
5090 * lepton-projectiles: initialize real photon instead
5091       IF ((IJP.EQ.3).OR.(IJP.EQ.4).OR.(IJP.EQ.10).OR.(IJP.EQ.11)) THEN
5092          IJP = 7
5093          Q2  = ZERO
5094       ENDIF
5095
5096       IF (LPHOIN) CALL PHO_INIT(-1,LOUT,IDUM)
5097
5098 * switch Reggeon off
5099 C     IPAMDL(3)= 0
5100       IF (IP.EQ.1) THEN
5101          IFPAP(1) = IDT_IPDGHA(IJP)
5102          IFPAB(1) = IJP
5103       ELSE
5104          IFPAP(1) = 2212
5105          IFPAB(1) = IDT_ICIHAD(IFPAP(1))
5106       ENDIF
5107       PMASS(1) = AAM(IFPAB(1))-SQRT(Q2)
5108       PVIRT(1) = PMASS(1)**2
5109       IF (IT.EQ.1) THEN
5110          IFPAP(2) = IDT_IPDGHA(IJT)
5111          IFPAB(2) = IJT
5112       ELSE
5113          IFPAP(2) = 2212
5114          IFPAB(2) = IDT_ICIHAD(IFPAP(2))
5115       ENDIF
5116       PMASS(2) = AAM(IFPAB(2))
5117       PVIRT(2) = ZERO
5118       DO 1 K=1,4
5119          PP(K) = ZERO
5120          PT(K) = ZERO
5121     1 CONTINUE
5122 * get max. possible momenta of incoming particles to be used for PHOJET ini.
5123       PPF = ZERO
5124       PTF = ZERO
5125       SCPF= 1.5D0
5126       IF (UMO.GE.1.E5) THEN
5127          SCPF= 5.0D0
5128       ENDIF
5129       IF (NCOMPO.GT.0) THEN
5130          DO 2 I=1,NCOMPO
5131             IF (IT.GT.1) THEN
5132                CALL DT_NCLPOT(IEMUCH(I),IEMUMA(I),ITZ,IT,ZERO,ZERO,0)
5133             ELSE
5134                CALL DT_NCLPOT(IPZ,IP,IEMUCH(I),IEMUMA(I),ZERO,ZERO,0)
5135             ENDIF
5136             PPFTMP = MAX(PFERMP(1),PFERMN(1))
5137             PTFTMP = MAX(PFERMP(2),PFERMN(2))
5138             IF (PPFTMP.GT.PPF) PPF = PPFTMP
5139             IF (PTFTMP.GT.PTF) PTF = PTFTMP
5140     2    CONTINUE
5141       ELSE
5142          CALL DT_NCLPOT(IPZ,IP,ITZ,IT,ZERO,ZERO,0)
5143          PPF = MAX(PFERMP(1),PFERMN(1))
5144          PTF = MAX(PFERMP(2),PFERMN(2))
5145       ENDIF
5146       PTF = -PTF
5147       PPF = SCPF*PPF
5148       PTF = SCPF*PTF
5149       IF (IJP.EQ.7) THEN
5150          AMP2  = SIGN(PMASS(1)**2,PMASS(1))
5151          PP(3) = PPCM
5152          PP(4) = SQRT(AMP2+PP(3)**2)
5153       ELSE
5154          EPF = SQRT(PPF**2+PMASS(1)**2)
5155          CALL DT_LTNUC(PPF,EPF,PP(3),PP(4),2)
5156       ENDIF
5157       ETF = SQRT(PTF**2+PMASS(2)**2)
5158       CALL DT_LTNUC(PTF,ETF,PT(3),PT(4),3)
5159       ECMINI = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
5160      &              (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
5161       IF (LSTART) THEN
5162          WRITE(LOUT,1001) IP,IPZ,SCPF,PPF,PP
5163  1001    FORMAT(
5164      &      ' DT_PHOINI:    PHOJET initialized for projectile A,Z = ',
5165      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
5166          IF (NCOMPO.GT.0) THEN
5167             WRITE(LOUT,1002) SCPF,PTF,PT
5168          ELSE
5169             WRITE(LOUT,1003) IT,ITZ,SCPF,PTF,PT
5170          ENDIF
5171  1002    FORMAT(
5172      &      ' DT_PHOINI:    PHOJET initialized for target emulsion  ',
5173      &          /,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
5174  1003    FORMAT(
5175      &      ' DT_PHOINI:    PHOJET initialized for target     A,Z = ',
5176      &      I3,',',I2,/,F4.1,'xp_F(max) = ',E10.3,'  p(max) = ',4E10.3)
5177          WRITE(LOUT,1004) ECMINI
5178  1004    FORMAT(' E_cm = ',E10.3)
5179          IF (IJP.EQ.8) WRITE(LOUT,1005)
5180  1005    FORMAT(
5181      &      ' DT_PHOINI: warning! proton parameters used for neutron',
5182      &          ' projectile')
5183          LSTART = .FALSE.
5184       ENDIF
5185 * switch off new diffractive cross sections at low energies for nuclei
5186 * (temporary solution)
5187       IF ((ISWMDL(30).NE.0).AND.((IP.GT.1).OR.(IT.GT.1))) THEN
5188          WRITE(LOUT,'(1X,A)')
5189      &      ' DT_PHOINI: model-switch 30 for nuclei re-set !'
5190          CALL PHO_SETMDL(30,0,1)
5191       ENDIF
5192 *
5193 C     IF (IJP.EQ.7) THEN
5194 C        AMP2  = SIGN(PMASS(1)**2,PMASS(1))
5195 C        PP(3) = PPCM
5196 C        PP(4) = SQRT(AMP2+PP(3)**2)
5197 C     ELSE
5198 C        PFERMX = ZERO
5199 C        IF (IP.GT.1) PFERMX = 0.5D0
5200 C        EFERMX = SQRT(PFERMX**2+PMASS(1)**2)
5201 C        CALL DT_LTNUC(PFERMX,EFERMX,PP(3),PP(4),2)
5202 C     ENDIF
5203 C     PFERMX = ZERO
5204 C     IF ((IT.GT.1).OR.(NCOMPO.GT.0)) PFERMX = -0.5D0
5205 C     EFERMX = SQRT(PFERMX**2+PMASS(2)**2)
5206 C     CALL DT_LTNUC(PFERMX,EFERMX,PT(3),PT(4),3)
5207 **sr 26.10.96
5208       ISAV = IPAMDL(13)
5209       IF ((ISHAD(2).EQ.1).AND.
5210      &   ((IJPROJ.EQ. 7).OR.(IJPROJ.EQ.3).OR.(IJPROJ.EQ.4).OR.
5211      &    (IJPROJ.EQ.10).OR.(IJPROJ.EQ.11))) IPAMDL(13) = 1
5212 **
5213
5214       CALL PHO_EVENT(-1,PP,PT,SIGMAX,IREJ1)
5215
5216 **sr 26.10.96
5217       IPAMDL(13) = ISAV
5218 **
5219 *
5220 * patch for cascade calculations:
5221 * define parton distribution functions for other hadrons, i.e. other
5222 * then defined already in phojet
5223       IF (IOGLB.EQ.100) THEN
5224          WRITE(LOUT,1006)
5225  1006    FORMAT(/,1X,'PHOINI: additional parton distribution functions',
5226      &          ' assiged (ID,IPAR,ISET)',/)
5227          NPDF = 0
5228          DO 3 I=1,30
5229             IF (IPARPD(I).NE.0) THEN
5230                NPDF = NPDF+1
5231                IF (NPDF.GT.MAXPDF) STOP ' PHOINI: npdf > maxpdf !'
5232                IF ((IPARPD(I).GT.0).AND.(ISETPD(I).GT.0)) THEN
5233                   IDPDG = IDT_IPDGHA(I)
5234                   IPAR  = IPARPD(I)
5235                   ISET  = ISETPD(I)
5236                   WRITE(LOUT,'(13X,A8,3I6)') ANAME(I),IDPDG,IPAR,ISET
5237                   CALL PHO_SETPDF(IDPDG,IDUM,IPAR,ISET,0,0,-1)
5238                ENDIF
5239             ENDIF
5240     3    CONTINUE
5241       ENDIF
5242
5243 C     CALL PHO_PHIST(-1,SIGMAX)
5244
5245       IF (IREJ1.NE.0) THEN
5246          WRITE(LOUT,1000)
5247  1000    FORMAT(1X,'PHOINI:   PHOJET event-initialization failed!')
5248          STOP
5249       ENDIF
5250
5251       RETURN
5252       END
5253
5254 *$ CREATE DT_EVENTD.FOR
5255 *COPY DT_EVENTD
5256 *
5257 *===eventd=============================================================*
5258 *
5259       SUBROUTINE DT_EVENTD(IREJ)
5260
5261 ************************************************************************
5262 * Quasi-elastic neutrino nucleus scattering.                           *
5263 * This version dated 29.04.00 is written by S. Roesler.                *
5264 ************************************************************************
5265
5266       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5267       SAVE
5268
5269       PARAMETER ( LINP = 10 ,
5270      &            LOUT = 6 ,
5271      &            LDAT = 9 )
5272
5273       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY5=1.0D-5)
5274       PARAMETER (SQTINF=1.0D+15)
5275
5276       LOGICAL LFIRST
5277
5278 * event history
5279
5280       PARAMETER (NMXHKK=200000)
5281
5282       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5283      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5284      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5285
5286 * extended event history
5287       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5288      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5289      &                IHIST(2,NMXHKK)
5290
5291 * flags for input different options
5292       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5293       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5294      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5295       PARAMETER (MAXLND=4000)
5296       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
5297
5298 * properties of interacting particles
5299       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5300
5301 * Lorentz-parameters of the current interaction
5302       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5303      &                UMO,PPCM,EPROJ,PPROJ
5304
5305 * nuclear potential
5306       LOGICAL LFERMI
5307       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5308      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5309      &                ETACOU(2),ICOUL,LFERMI
5310
5311 * steering flags for qel neutrino scattering modules
5312       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
5313
5314       COMMON /QNPOL/ POLARX(4),PMODUL
5315
5316       INTEGER PYK
5317
5318       DATA LFIRST /.TRUE./
5319
5320       IREJ = 0
5321
5322       IF (LFIRST) THEN
5323          LFIRST = .FALSE.
5324          CALL DT_MASS_INI
5325       ENDIF
5326
5327 * JETSET parameter
5328       CALL DT_INITJS(0)
5329
5330 * interacting target nucleon
5331       LTYP = NEUTYP
5332       IF (NEUDEC.LE.9) THEN
5333          IF ((LTYP.EQ.1).OR.(LTYP.EQ.3).OR.(LTYP.EQ.5)) THEN
5334             NUCTYP = 2112
5335             NUCTOP = 2
5336          ELSE
5337             NUCTYP = 2212
5338             NUCTOP = 1
5339          ENDIF
5340       ELSE
5341          RTYP  = DT_RNDM(RTYP)
5342          ZFRAC = DBLE(ITZ)/DBLE(IT)
5343          IF (RTYP.LE.ZFRAC) THEN
5344             NUCTYP = 2212
5345             NUCTOP = 1
5346          ELSE
5347             NUCTYP = 2112
5348             NUCTOP = 2
5349          ENDIF
5350       ENDIF
5351
5352 * select first nucleon in list with matching id and reset all other
5353 * nucleons which have been marked as "wounded" by ININUC
5354       IFOUND = 0
5355       DO 1 I=1,NHKK
5356          IF ((IDHKK(I).EQ.NUCTYP).AND.(IFOUND.EQ.0)) THEN
5357             ISTHKK(I) = 12
5358             IFOUND    = 1
5359             IDX = I
5360          ELSE
5361             IF (ISTHKK(I).EQ.12) ISTHKK(I) = 14
5362          ENDIF
5363     1 CONTINUE
5364       IF (IFOUND.EQ.0)
5365      &   STOP ' EVENTD: interacting target nucleon not found! '
5366
5367 * correct position of proj. lepton: assume position of target nucleon
5368       DO 3 I=1,4
5369          VHKK(I,1) = VHKK(I,IDX)
5370          WHKK(I,1) = WHKK(I,IDX)
5371     3 CONTINUE
5372
5373 * load initial momenta for conservation check
5374       IF (LEMCCK) THEN
5375          CALL DT_EVTEMC(ZERO,ZERO,PPROJ,EPROJ,1,IDUM,IDUM)
5376          CALL DT_EVTEMC(PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),PHKK(4,IDX),
5377      &                                                      2,IDUM,IDUM)
5378       ENDIF
5379
5380 * quasi-elastic scattering
5381       IF (NEUDEC.LT.9) THEN
5382          CALL DT_QEL_POL(EPROJ,LTYP,PHKK(1,IDX),PHKK(2,IDX),PHKK(3,IDX),
5383      &                                          PHKK(4,IDX),PHKK(5,IDX))
5384 *  CC event on p or n
5385       ELSEIF (NEUDEC.EQ.10) THEN
5386          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,1,PHKK(1,IDX),PHKK(2,IDX),
5387      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5388 *  NC event on p or n
5389       ELSEIF (NEUDEC.EQ.11) THEN
5390          CALL DT_GEN_DELTA(EPROJ,LTYP,NUCTOP,2,PHKK(1,IDX),PHKK(2,IDX),
5391      &                     PHKK(3,IDX),PHKK(4,IDX),PHKK(5,IDX))
5392       ENDIF
5393
5394 * get final state particles from Lund-common and write them into HKKEVT
5395       NPOINT(1) = NHKK+1
5396       NPOINT(4) = NHKK+1
5397
5398       NLINES = PYK(0,1)
5399
5400       NHKK0  = NHKK+1
5401       DO 4 I=4,NLINES
5402          IF (K(I,1).EQ.1) THEN
5403             ID = K(I,2)
5404             PX = P(I,1)
5405             PY = P(I,2)
5406             PZ = P(I,3)
5407             PE = P(I,4)
5408             CALL DT_EVTPUT(1,ID,1,IDX,PX,PY,PZ,PE,0,0,0)
5409             IDBJ = IDT_ICIHAD(ID)
5410             EKIN = PHKK(4,NHKK)-PHKK(5,NHKK)
5411             IF ((IDBJ.EQ.1).OR.(IDBJ.EQ.8)) THEN
5412                IF (EKIN.LE.EPOT(2,IDBJ)) ISTHKK(NHKK) = 16
5413             ENDIF
5414             VHKK(1,NHKK) = VHKK(1,IDX)
5415             VHKK(2,NHKK) = VHKK(2,IDX)
5416             VHKK(3,NHKK) = VHKK(3,IDX)
5417             VHKK(4,NHKK) = VHKK(4,IDX)
5418 C           IF (I.EQ.4) THEN
5419 C              WHKK(1,NHKK) = POLARX(1)
5420 C              WHKK(2,NHKK) = POLARX(2)
5421 C              WHKK(3,NHKK) = POLARX(3)
5422 C              WHKK(4,NHKK) = POLARX(4)
5423 C           ELSE
5424                WHKK(1,NHKK) = WHKK(1,IDX)
5425                WHKK(2,NHKK) = WHKK(2,IDX)
5426                WHKK(3,NHKK) = WHKK(3,IDX)
5427                WHKK(4,NHKK) = WHKK(4,IDX)
5428 C           ENDIF
5429             IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
5430          ENDIF
5431     4 CONTINUE
5432
5433       IF (LEMCCK) THEN
5434          CHKLEV = TINY5
5435          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,778,IREJ1)
5436          IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
5437       ENDIF
5438
5439 * transform momenta into cms (as required for inc etc.)
5440       DO 5 I=NHKK0,NHKK
5441          IF (ISTHKK(I).EQ.1) THEN
5442             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,3)
5443             PHKK(3,I) = PZ
5444             PHKK(4,I) = PE
5445          ENDIF
5446     5 CONTINUE
5447
5448       RETURN
5449       END
5450 *$ CREATE DT_KKEVNT.FOR
5451 *COPY DT_KKEVNT
5452 *
5453 *===kkevnt=============================================================*
5454 *
5455       SUBROUTINE DT_KKEVNT(KKMAT,IREJ)
5456
5457 ************************************************************************
5458 * Treatment of complete nucleus-nucleus or hadron-nucleus scattering   *
5459 * without nuclear effects (one event).                                 *
5460 * This subroutine is an update of the previous version (KKEVT) written *
5461 * by J. Ranft/ H.-J. Moehring.                                         *
5462 * This version dated 20.04.95 is written by S. Roesler                 *
5463 ************************************************************************
5464
5465       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5466       SAVE
5467
5468       PARAMETER ( LINP = 10 ,
5469      &            LOUT = 6 ,
5470      &            LDAT = 9 )
5471
5472       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10)
5473
5474       PARAMETER ( MAXNCL = 260,
5475
5476      &            MAXVQU = MAXNCL,
5477      &            MAXSQU = 20*MAXVQU,
5478      &            MAXINT = MAXVQU+MAXSQU)
5479
5480 * event history
5481
5482       PARAMETER (NMXHKK=200000)
5483
5484       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5485      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5486      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5487
5488 * extended event history
5489       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5490      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5491      &                IHIST(2,NMXHKK)
5492
5493 * flags for input different options
5494       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5495       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5496      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5497
5498 * rejection counter
5499       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
5500      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
5501      &                IREXCI(3),IRDIFF(2),IRINC
5502
5503 * statistics
5504       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5505      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5506      &                ICEVTG(8,0:30)
5507
5508 * properties of interacting particles
5509       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
5510
5511 * Lorentz-parameters of the current interaction
5512       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
5513      &                UMO,PPCM,EPROJ,PPROJ
5514
5515 * flags for diffractive interactions (DTUNUC 1.x)
5516       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
5517
5518 * interface HADRIN-DPM
5519       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5520
5521 * nucleon-nucleon event-generator
5522       CHARACTER*8 CMODEL
5523       LOGICAL LPHOIN
5524       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
5525
5526 * coordinates of nucleons
5527       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
5528
5529 * interface between Glauber formalism and DPM
5530       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
5531      &                INTER1(MAXINT),INTER2(MAXINT)
5532
5533 * Glauber formalism: collision properties
5534       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5535      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC,
5536      &                NCP,NCT
5537
5538 * central particle production, impact parameter biasing
5539       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5540 **temporary
5541
5542 * statistics: Glauber-formalism
5543       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
5544 **
5545
5546       DATA NEVOLD,IPOLD,ITOLD,JJPOLD,EPROLD /4*0,0.0D0/
5547
5548       IREJ   = 0
5549       ICREQU = ICREQU+1
5550       NC     = 0
5551       NCP    = 0
5552       NCT    = 0
5553
5554     1 CONTINUE
5555       ICSAMP = ICSAMP+1
5556       NC     = NC+1
5557       IF (MOD(NC,10).EQ.0) THEN
5558          WRITE(LOUT,1000) NEVHKK
5559  1000    FORMAT(1X,'KKEVNT: event ',I8,' rejected!')
5560          GOTO 9999
5561       ENDIF
5562
5563 * initialize DTEVT1/DTEVT2
5564       CALL DT_EVTINI
5565
5566 * We need the following only in order to sample nucleon coordinates.
5567 * However we don't have parameters (cross sections, slope etc.)
5568 * for neutrinos available. Therefore switch projectile to proton
5569 * in this case.
5570       IF (MCGENE.EQ.4) THEN
5571          JJPROJ = 1
5572       ELSE
5573          JJPROJ = IJPROJ
5574       ENDIF
5575
5576    10 CONTINUE
5577       IF ( (NEVHKK.NE.NEVOLD).OR.(ICENTR.GT.0).OR.
5578 * make sure that Glauber-formalism is called each time the interaction
5579 * configuration changed
5580      &     (IP.NE.IPOLD).OR.(IT.NE.ITOLD).OR.(JJPROJ.NE.JJPOLD).OR.
5581      &     (ABS(EPROJ-EPROLD).GT.TINY10) ) THEN
5582 * sample number of nucleon-nucleon coll. according to Glauber-form.
5583          CALL DT_GLAUBE(IP,IT,JJPROJ,BIMPAC,NN,NP,NT,JSSH,JTSH,KKMAT)
5584          NWTSAM = NN
5585          NWASAM = NP
5586          NWBSAM = NT
5587          NEVOLD = NEVHKK
5588          IPOLD  = IP
5589          ITOLD  = IT
5590          JJPOLD = JJPROJ
5591          EPROLD = EPROJ
5592      DO 8 I=1, IP
5593         NCP = NCP+JSSH(I)
5594 *        WRITE(6,*)' PROJ.NUCL. ',I,' NCOLL = ',NCP
5595     8 CONTINUE
5596      DO 9 I=1, IT
5597         NCT = NCT+JTSH(I)
5598 *        WRITE(6,*)' TAR.NUCL. ',I,' NCOLL = ',NCT
5599     9 CONTINUE
5600       ENDIF
5601
5602 * force diffractive particle production in h-K interactions
5603       IF (((ABS(ISINGD).GT.1).OR.(ABS(IDOUBD).GT.1)).AND.
5604      &    (IP.EQ.1).AND.(NN.NE.1)) THEN
5605          NEVOLD = 0
5606          GOTO 10
5607       ENDIF
5608
5609 * check number of involved proj. nucl. (NP) if central prod.is requested
5610       IF (ICENTR.GT.0) THEN
5611          CALL DT_CHKCEN(IP,IT,NP,NT,IBACK)
5612          IF (IBACK.GT.0) GOTO 10
5613       ENDIF
5614
5615 * get initial nucleon-configuration in projectile and target
5616 * rest-system (including Fermi-momenta if requested)
5617       CALL DT_ININUC(IJPROJ,IP,IPZ,PKOO,JSSH,1)
5618       MODE = 2
5619       IF (EPROJ.LE.EHADTH) MODE = 3
5620       CALL DT_ININUC(IJTARG,IT,ITZ,TKOO,JTSH,MODE)
5621
5622       IF ((MCGENE.NE.3).AND.(MCGENE.NE.4)) THEN
5623
5624 * activate HADRIN at low energies (implemented for h-N scattering only)
5625          IF (EPROJ.LE.EHADHI) THEN
5626             IF (EHADTH.LT.ZERO) THEN
5627 *   smooth transition btwn. DPM and HADRIN
5628                FRAC = (EPROJ-EHADLO)/(EHADHI-EHADLO)
5629                RR   = DT_RNDM(FRAC)
5630                IF (RR.GT.FRAC) THEN
5631                   IF (IP.EQ.1) THEN
5632                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5633                      IF (IREJ1.GT.0) GOTO 1
5634                      RETURN
5635                   ELSE
5636                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5637                   ENDIF
5638                ENDIF
5639             ELSE
5640 *   fixed threshold for onset of production via HADRIN
5641                IF (EPROJ.LE.EHADTH) THEN
5642                   IF (IP.EQ.1) THEN
5643                      CALL DT_HADCOL(IJPROJ,PPROJ,IDXTA,IREJ1)
5644                      IF (IREJ1.GT.0) GOTO 1
5645                      RETURN
5646                   ELSE
5647                      WRITE(LOUT,1001) IP,IT,EPROJ,EHADTH
5648                   ENDIF
5649                ENDIF
5650             ENDIF
5651          ENDIF
5652  1001    FORMAT(1X,'KKEVNT:   warning! interaction of proj. (m=',
5653      &          I3,') with target (m=',I3,')',/,11X,
5654      &          'at E_lab=',F5.1,'GeV (threshold-energy: ',F3.1,
5655      &          'GeV) cannot be handled')
5656
5657 * sampling of momentum-x fractions & flavors of chain ends
5658          CALL DT_SPLPTN(NN)
5659
5660 * Lorentz-transformation of wounded nucleons into nucl.-nucl. cms
5661          CALL DT_NUC2CM
5662
5663 * collect momenta of chain ends and put them into DTEVT1
5664          CALL DT_GETPTN(IP,NN,NCSY,IREJ1)
5665          IF (IREJ1.NE.0) GOTO 1
5666
5667       ENDIF
5668
5669 * handle chains including fragmentation (two-chain approximation)
5670       IF (MCGENE.EQ.1) THEN
5671 *  two-chain approximation
5672          CALL DT_EVENTA(IJPROJ,IP,IT,NCSY,IREJ1)
5673          IF (IREJ1.NE.0) THEN
5674             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in KKEVNT'
5675             GOTO 1
5676          ENDIF
5677       ELSEIF (MCGENE.EQ.2) THEN
5678 *  multiple-Po exchange including minijets
5679          CALL DT_EVENTB(NCSY,IREJ1)
5680          IF (IREJ1.NE.0) THEN
5681             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in KKEVNT'
5682             GOTO 1
5683          ENDIF
5684       ELSEIF (MCGENE.EQ.3) THEN
5685          STOP ' This version does not contain LEPTO !'
5686
5687       ELSEIF (MCGENE.EQ.4) THEN
5688 *  quasi-elastic neutrino scattering
5689          CALL DT_EVENTD(IREJ1)
5690          IF (IREJ1.NE.0) THEN
5691             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 4 in KKEVNT'
5692             GOTO 1
5693          ENDIF
5694       ELSE
5695          WRITE(LOUT,1002) MCGENE
5696  1002    FORMAT(1X,'KKEVNT:   warning! event-generator',I4,
5697      &         ' not available - program stopped')
5698          STOP
5699       ENDIF
5700
5701       RETURN
5702
5703  9999 CONTINUE
5704       IREJ = 1
5705       RETURN
5706       END
5707
5708 *$ CREATE DT_CHKCEN.FOR
5709 *COPY DT_CHKCEN
5710 *
5711 *===chkcen=============================================================*
5712 *
5713       SUBROUTINE DT_CHKCEN(IP,IT,NP,NT,IBACK)
5714
5715 ************************************************************************
5716 * Check of number of involved projectile nucleons if central production*
5717 * is requested.                                                        *
5718 * Adopted from a part of the old KKEVT routine which was written by    *
5719 * J. Ranft/H.-J.Moehring.                                              *
5720 * This version dated 13.01.95 is written by S. Roesler                 *
5721 ************************************************************************
5722
5723       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5724       SAVE
5725
5726       PARAMETER ( LINP = 10 ,
5727      &            LOUT = 6 ,
5728      &            LDAT = 9 )
5729
5730 * statistics
5731       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
5732      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
5733      &                ICEVTG(8,0:30)
5734
5735 * central particle production, impact parameter biasing
5736       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
5737
5738       IBACK = 0
5739
5740 * old version
5741       IF (ICENTR.EQ.2) THEN
5742          IF (IP.LT.IT) THEN
5743             IF (IP.LE.8) THEN
5744                IF (NP.LT.IP-1) IBACK = 1
5745             ELSEIF (IP.LE.16) THEN
5746                IF (NP.LT.IP-2) IBACK = 1
5747             ELSEIF (IP.LE.32) THEN
5748                IF (NP.LT.IP-3) IBACK = 1
5749             ELSEIF (IP.GE.33) THEN
5750                IF (NP.LT.IP-5) IBACK = 1
5751             ENDIF
5752          ELSEIF (IP.EQ.IT) THEN
5753             IF (IP.EQ.32) THEN
5754                IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5755             ELSE
5756                IF (NP.LT.IP-IP/8) IBACK = 1
5757             ENDIF
5758          ELSEIF (ABS(IP-IT).LT.3) THEN
5759             IF (NP.LT.IP-IP/8) IBACK = 1
5760          ENDIF
5761       ELSE
5762 * new version (DPMJET, 5.6.99)
5763          IF (IP.LT.IT) THEN
5764             IF (IP.LE.8) THEN
5765                IF (NP.LT.IP-1) IBACK = 1
5766             ELSEIF (IP.LE.16) THEN
5767                IF (NP.LT.IP-2) IBACK = 1
5768             ELSEIF (IP.LT.32) THEN
5769                IF (NP.LT.IP-3) IBACK = 1
5770             ELSEIF (IP.GE.32) THEN
5771                IF (IT.LE.150) THEN
5772 *   Example: S-Ag
5773                   IF (NP.LT.IP-1) IBACK = 1
5774                ELSE
5775 *   Example: S-Au
5776                   IF (NP.LT.IP) IBACK = 1
5777                ENDIF
5778             ENDIF
5779          ELSEIF (IP.EQ.IT) THEN
5780 *   Example: S-S
5781            IF (IP.EQ.32) THEN
5782               IF ((NP.LT.22).OR.(NT.LT.22)) IBACK = 1
5783 *   Example: Pb-Pb
5784            ELSE
5785               IF (NP.LT.IP-IP/4) IBACK = 1
5786            ENDIF
5787          ELSEIF (ABS(IP-IT).LT.3) THEN
5788             IF (NP.LT.IP-IP/8) IBACK = 1
5789          ENDIF
5790       ENDIF
5791
5792       ICCPRO = ICCPRO+1
5793
5794       RETURN
5795       END
5796
5797 *$ CREATE DT_ININUC.FOR
5798 *COPY DT_ININUC
5799 *
5800 *===ininuc=============================================================*
5801 *
5802       SUBROUTINE DT_ININUC(ID,NMASS,NCH,COORD,JS,IMODE)
5803
5804 ************************************************************************
5805 * Samples initial configuration of nucleons in nucleus with mass NMASS *
5806 * including Fermi-momenta (if reqested).                               *
5807 *          ID             BAMJET-code for hadrons (instead of nuclei)  *
5808 *          NMASS          mass number of nucleus (number of nucleons)  *
5809 *          NCH            charge of nucleus                            *
5810 *          COORD(3,NMASS) coordinates of nucleons inside nucleus in fm *
5811 *          JS(NMASS) > 0  nucleon undergoes nucleon-nucleon interact.  *
5812 *          IMODE = 1      projectile nucleus                           *
5813 *                = 2      target     nucleus                           *
5814 *                = 3      target     nucleus (E_lab<E_thr for HADRIN)  *
5815 * Adopted from a part of the old KKEVT routine which was written by    *
5816 * J. Ranft/H.-J.Moehring.                                              *
5817 * This version dated 13.01.95 is written by S. Roesler                 *
5818 ************************************************************************
5819
5820       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
5821       SAVE
5822
5823       PARAMETER ( LINP = 10 ,
5824      &            LOUT = 6 ,
5825      &            LDAT = 9 )
5826
5827       PARAMETER (FM2MM=1.0D-12)
5828
5829       PARAMETER ( MAXNCL = 260,
5830
5831      &            MAXVQU = MAXNCL,
5832      &            MAXSQU = 20*MAXVQU,
5833      &            MAXINT = MAXVQU+MAXSQU)
5834
5835 * event history
5836
5837       PARAMETER (NMXHKK=200000)
5838
5839       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
5840      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
5841      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
5842
5843 * extended event history
5844       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
5845      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
5846      &                IHIST(2,NMXHKK)
5847
5848 * flags for input different options
5849       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
5850       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
5851      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
5852
5853 * auxiliary common for chain system storage (DTUNUC 1.x)
5854       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
5855
5856 * nuclear potential
5857       LOGICAL LFERMI
5858       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
5859      &                EBINDP(2),EBINDN(2),EPOT(2,210),
5860      &                ETACOU(2),ICOUL,LFERMI
5861
5862 * properties of photon/lepton projectiles
5863       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
5864
5865 * particle properties (BAMJET index convention)
5866       CHARACTER*8  ANAME
5867       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
5868      &                IICH(210),IIBAR(210),K1(210),K2(210)
5869
5870 * Glauber formalism: collision properties
5871       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
5872      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
5873
5874 * flavors of partons (DTUNUC 1.x)
5875       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
5876      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
5877      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
5878      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
5879      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
5880      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
5881      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
5882
5883 * interface HADRIN-DPM
5884       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
5885
5886       DIMENSION PF(4),PFTOT(4),COORD(3,MAXNCL),JS(MAXNCL)
5887
5888 * number of neutrons
5889       NNEU = NMASS-NCH
5890 * initializations
5891       NP = 0
5892       NN = 0
5893       DO 1 K=1,4
5894          PFTOT(K) = 0.0D0
5895     1 CONTINUE
5896       MODE   = IMODE
5897       IF (IMODE.GT.2) MODE = 2
5898 **sr 29.5. new NPOINT(1)-definition
5899 C     IF (IMODE.GE.2) NPOINT(1) = NHKK+1
5900 **
5901       NHADRI = 0
5902       NC     = NHKK
5903
5904 * get initial configuration
5905       DO 2 I=1,NMASS
5906          NHKK = NHKK+1
5907          IF (JS(I).GT.0) THEN
5908             ISTHKK(NHKK) = 10+MODE
5909             IF (IMODE.EQ.3) THEN
5910 *   additional treatment if HADRIN-generator is requested
5911                NHADRI = NHADRI+1
5912                IF (NHADRI.EQ.1) IDXTA  = NHKK
5913                IF (NHADRI.GT.1) ISTHKK(NHKK) = 14
5914             ENDIF
5915          ELSE
5916             ISTHKK(NHKK) = 12+MODE
5917          ENDIF
5918          IF (NMASS.GE.2) THEN
5919 *   treatment for nuclei
5920             FRAC = 1.0D0-DBLE(NCH)/DBLE(NMASS)
5921             RR   = DT_RNDM(FRAC)
5922             IF ((RR.LT.FRAC).AND.(NN.LT.NNEU)) THEN
5923                IDX = 8
5924                NN  = NN+1
5925             ELSEIF ((RR.GE.FRAC).AND.(NP.LT.NCH)) THEN
5926                IDX = 1
5927                NP  = NP+1
5928             ELSEIF (NN.LT.NNEU) THEN
5929                IDX = 8
5930                NN  = NN+1
5931             ELSEIF (NP.LT.NCH)  THEN
5932                IDX = 1
5933                NP  = NP+1
5934             ENDIF
5935             IDHKK(NHKK) = IDT_IPDGHA(IDX)
5936             IDBAM(NHKK) = IDX
5937             IF (MODE.EQ.1) THEN
5938                IPOSP(I)  = NHKK
5939                KKPROJ(I) = IDX
5940             ELSE
5941                IPOST(I)  = NHKK
5942                KKTARG(I) = IDX
5943             ENDIF
5944             IF (IDX.EQ.1) THEN
5945                PFER = PFERMP(MODE)
5946                PBIN = SQRT(2.0D0*EBINDP(MODE)*AAM(1))
5947             ELSE
5948                PFER = PFERMN(MODE)
5949                PBIN = SQRT(2.0D0*EBINDN(MODE)*AAM(8))
5950             ENDIF
5951             CALL DT_FER4M(PFER,PBIN,PF(1),PF(2),PF(3),PF(4),IDX)
5952             DO 3 K=1,4
5953                PFTOT(K) = PFTOT(K)+PF(K)
5954                PHKK(K,NHKK) = PF(K)
5955     3       CONTINUE
5956             PHKK(5,NHKK) = AAM(IDX)
5957          ELSE
5958 *   treatment for hadrons
5959             IDHKK(NHKK)  = IDT_IPDGHA(ID)
5960             IDBAM(NHKK)  = ID
5961             PHKK(4,NHKK) = AAM(ID)
5962             PHKK(5,NHKK) = AAM(ID)
5963 C* VDM assumption
5964 C            IF (IDHKK(NHKK).EQ.22) THEN
5965 C               PHKK(4,NHKK) = AAM(33)
5966 C               PHKK(5,NHKK) = AAM(33)
5967 C            ENDIF
5968             IF (MODE.EQ.1) THEN
5969                IPOSP(I)  = NHKK
5970                KKPROJ(I) = ID
5971                PHKK(5,NHKK) = PHKK(5,NHKK)-SQRT(VIRT)
5972             ELSE
5973                IPOST(I)  = NHKK
5974                KKTARG(I) = ID
5975             ENDIF
5976          ENDIF
5977          DO 4 K=1,3
5978             VHKK(K,NHKK) = COORD(K,I)*FM2MM
5979             WHKK(K,NHKK) = COORD(K,I)*FM2MM
5980     4    CONTINUE
5981          IF (MODE.EQ.2) VHKK(1,NHKK) = VHKK(1,NHKK)+BIMPAC*FM2MM
5982          IF (MODE.EQ.2) WHKK(1,NHKK) = WHKK(1,NHKK)+BIMPAC*FM2MM
5983          VHKK(4,NHKK) = 0.0D0
5984          WHKK(4,NHKK) = 0.0D0
5985     2 CONTINUE
5986
5987 * balance Fermi-momenta
5988       IF (NMASS.GE.2) THEN
5989          DO 5 I=1,NMASS
5990             NC = NC+1
5991             DO 6 K=1,3
5992                PHKK(K,NC) = PHKK(K,NC)-PFTOT(K)/DBLE(NMASS)
5993     6       CONTINUE
5994             PHKK(4,NC) = SQRT(PHKK(5,NC)**2+PHKK(1,NC)**2+
5995      &                        PHKK(2,NC)**2+PHKK(3,NC)**2)
5996     5    CONTINUE
5997       ENDIF
5998
5999       RETURN
6000       END
6001
6002 *$ CREATE DT_FER4M.FOR
6003 *COPY DT_FER4M
6004 *
6005 *===fer4m==============================================================*
6006 *
6007       SUBROUTINE DT_FER4M(PFERM,PBIND,PXT,PYT,PZT,ET,KT)
6008
6009 ************************************************************************
6010 * Sampling of nucleon Fermi-momenta from distributions at T=0.         *
6011 *                                   processed by S. Roesler, 17.10.95  *
6012 ************************************************************************
6013
6014       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6015       SAVE
6016
6017       PARAMETER ( LINP = 10 ,
6018      &            LOUT = 6 ,
6019      &            LDAT = 9 )
6020
6021       LOGICAL LSTART
6022
6023 * particle properties (BAMJET index convention)
6024       CHARACTER*8  ANAME
6025       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6026      &                IICH(210),IIBAR(210),K1(210),K2(210)
6027
6028 * nuclear potential
6029       LOGICAL LFERMI
6030       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
6031      &                EBINDP(2),EBINDN(2),EPOT(2,210),
6032      &                ETACOU(2),ICOUL,LFERMI
6033
6034       DATA LSTART /.TRUE./
6035
6036       ILOOP = 0
6037       IF (LFERMI) THEN
6038          IF (LSTART) THEN
6039             WRITE(LOUT,1000)
6040  1000       FORMAT(/,1X,'FER4M:   sampling of Fermi-momenta activated')
6041             LSTART = .FALSE.
6042          ENDIF
6043     1    CONTINUE
6044          CALL DT_DFERMI(PABS)
6045          PABS = PFERM*PABS
6046 C        IF (PABS.GE.PBIND) THEN
6047 C           ILOOP = ILOOP+1
6048 C           IF (MOD(ILOOP,500).EQ.0) THEN
6049 C              WRITE(LOUT,1001) PABS,PBIND,ILOOP
6050 C1001          FORMAT(1X,'FER4M:    Fermi-mom. corr. for binding',
6051 C    &                ' energy ',2E12.3,I6)
6052 C           ENDIF
6053 C           GOTO 1
6054 C        ENDIF
6055          CALL DT_DPOLI(POLC,POLS)
6056          CALL DT_DSFECF(SFE,CFE)
6057          CXTA = POLS*CFE
6058          CYTA = POLS*SFE
6059          CZTA = POLC
6060          ET   = SQRT(PABS*PABS+AAM(KT)**2)
6061          PXT  = CXTA*PABS
6062          PYT  = CYTA*PABS
6063          PZT  = CZTA*PABS
6064       ELSE
6065          ET   = AAM(KT)
6066          PXT  = 0.0D0
6067          PYT  = 0.0D0
6068          PZT  = 0.0D0
6069       ENDIF
6070
6071       RETURN
6072       END
6073
6074 *$ CREATE DT_NUC2CM.FOR
6075 *COPY DT_NUC2CM
6076 *
6077 *===nuc2cm=============================================================*
6078 *
6079       SUBROUTINE DT_NUC2CM
6080
6081 ************************************************************************
6082 * Lorentz-transformation of all wounded nucleons from Lab. to nucl.-   *
6083 * nucl. cms. (This subroutine replaces NUCMOM.)                        *
6084 * This version dated 15.01.95 is written by S. Roesler                 *
6085 ************************************************************************
6086
6087       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6088       SAVE
6089
6090       PARAMETER ( LINP = 10 ,
6091      &            LOUT = 6 ,
6092      &            LDAT = 9 )
6093
6094       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
6095
6096 * event history
6097
6098       PARAMETER (NMXHKK=200000)
6099
6100       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6101      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6102      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6103
6104 * extended event history
6105       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6106      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6107      &                IHIST(2,NMXHKK)
6108
6109 * statistics
6110       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6111      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6112      &                ICEVTG(8,0:30)
6113
6114 * properties of photon/lepton projectiles
6115       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
6116
6117 * particle properties (BAMJET index convention)
6118       CHARACTER*8  ANAME
6119       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6120      &                IICH(210),IIBAR(210),K1(210),K2(210)
6121
6122 * Glauber formalism: collision properties
6123       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
6124      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
6125 **temporary
6126
6127 * statistics: Glauber-formalism
6128       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
6129 **
6130
6131       ICWP = 0
6132       ICWT = 0
6133       NWTACC = 0
6134       NWAACC = 0
6135       NWBACC = 0
6136
6137       NPOINT(1) = NHKK+1
6138       NEND      = NHKK
6139       DO 1 I=1,NEND
6140          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.12)) THEN
6141             IF (ISTHKK(I).EQ.11) NWAACC = NWAACC+1
6142             IF (ISTHKK(I).EQ.12) NWBACC = NWBACC+1
6143             MODE = ISTHKK(I)-9
6144 C            IF (IDHKK(I).EQ.22) THEN
6145 C* VDM assumption
6146 C               PEIN = AAM(33)
6147 C               IDB  = 33
6148 C            ELSE
6149 C               PEIN = PHKK(4,I)
6150 C               IDB  = IDBAM(I)
6151 C            ENDIF
6152 C            CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PEIN,
6153 C     &           PX,PY,PZ,PE,IDB,MODE)
6154             IF (PHKK(5,I).GT.ZERO) THEN
6155                CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
6156      &              PX,PY,PZ,PE,IDBAM(I),MODE)
6157             ELSE
6158                PX = PGAMM(1)
6159                PY = PGAMM(2)
6160                PZ = PGAMM(3)
6161                PE = PGAMM(4)
6162             ENDIF
6163             IST = ISTHKK(I)-2
6164             ID  = IDHKK(I)
6165 C* VDM assumption
6166 C            IF (ID.EQ.22) ID = 113
6167             CALL DT_EVTPUT(IST,ID,I,0,PX,PY,PZ,PE,0,0,0)
6168             IF (ISTHKK(I).EQ.11) ICWP = ICWP+1
6169             IF (ISTHKK(I).EQ.12) ICWT = ICWT+1
6170          ENDIF
6171     1 CONTINUE
6172
6173       NWTACC = MAX(NWAACC,NWBACC)
6174       ICDPR  = ICDPR+ICWP
6175       ICDTA  = ICDTA+ICWT
6176 **temporary
6177       IF ((ICWP.EQ.0).OR.(ICWT.EQ.0)) THEN
6178          CALL DT_EVTOUT(4)
6179          STOP
6180       ENDIF
6181
6182       RETURN
6183       END
6184
6185 *$ CREATE DT_SPLPTN.FOR
6186 *COPY DT_SPLPTN
6187 *
6188 *===splptn=============================================================*
6189 *
6190       SUBROUTINE DT_SPLPTN(NN)
6191
6192 ************************************************************************
6193 * SamPLing of ParToN momenta and flavors.                              *
6194 * This version dated 15.01.95 is written by S. Roesler                 *
6195 ************************************************************************
6196
6197       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6198       SAVE
6199
6200       PARAMETER ( LINP = 10 ,
6201      &            LOUT = 6 ,
6202      &            LDAT = 9 )
6203
6204 * Lorentz-parameters of the current interaction
6205       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
6206      &                UMO,PPCM,EPROJ,PPROJ
6207
6208 * sample flavors of sea-quarks
6209       CALL DT_SPLFLA(NN,1)
6210
6211 * sample x-values of partons at chain ends
6212       ECM = UMO
6213       CALL DT_XKSAMP(NN,ECM)
6214
6215 * samle flavors
6216       CALL DT_SPLFLA(NN,2)
6217
6218       RETURN
6219       END
6220
6221 *$ CREATE DT_SPLFLA.FOR
6222 *COPY DT_SPLFLA
6223 *
6224 *===splfla=============================================================*
6225 *
6226       SUBROUTINE DT_SPLFLA(NN,MODE)
6227
6228 ************************************************************************
6229 * SamPLing of FLAvors of partons at chain ends.                        *
6230 * This subroutine replaces FLKSAA/FLKSAM.                              *
6231 *            NN            number of nucleon-nucleon interactions      *
6232 *            MODE = 1      sea-flavors                                 *
6233 *                 = 2      valence-flavors                             *
6234 * Based on the original version written by J. Ranft/H.-J. Moehring.    *
6235 * This version dated 16.01.95 is written by S. Roesler                 *
6236 ************************************************************************
6237
6238       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6239       SAVE
6240
6241       PARAMETER ( LINP = 10 ,
6242      &            LOUT = 6 ,
6243      &            LDAT = 9 )
6244
6245       PARAMETER ( MAXNCL = 260,
6246
6247      &            MAXVQU = MAXNCL,
6248      &            MAXSQU = 20*MAXVQU,
6249      &            MAXINT = MAXVQU+MAXSQU)
6250
6251 * flavors of partons (DTUNUC 1.x)
6252       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6253      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6254      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
6255      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6256      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
6257      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6258      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
6259
6260 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6261       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6262      &                IXPV,IXPS,IXTV,IXTS,
6263      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
6264      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
6265      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
6266      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
6267      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
6268      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
6269      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
6270      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
6271
6272 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6273       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6274      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6275
6276 * particle properties (BAMJET index convention)
6277       CHARACTER*8  ANAME
6278       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6279      &                IICH(210),IIBAR(210),K1(210),K2(210)
6280
6281 * various options for treatment of partons (DTUNUC 1.x)
6282 * (chain recombination, Cronin,..)
6283       LOGICAL LCO2CR,LINTPT
6284       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6285      &                LCO2CR,LINTPT
6286
6287       IF (MODE.EQ.1) THEN
6288 * sea-flavors
6289          DO 1 I=1,NN
6290             IPSQ(I)  = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6291             IPSAQ(I) = -IPSQ(I)
6292     1    CONTINUE
6293          DO 2 I=1,NN
6294             ITSQ(I) = INT(1.0D0+DT_RNDM(CRONCO)*(2.0D0+SEASQ))
6295             ITSAQ(I)= -ITSQ(I)
6296     2    CONTINUE
6297       ELSEIF (MODE.EQ.2) THEN
6298 * valence flavors
6299          DO 3 I=1,IXPV
6300             CALL DT_FLAHAD(KKPROJ(IFROVP(I)),IPVQ(I),IPPV1(I),IPPV2(I))
6301     3    CONTINUE
6302          DO 4 I=1,IXTV
6303             CALL DT_FLAHAD(KKTARG(IFROVT(I)),ITVQ(I),ITTV1(I),ITTV2(I))
6304     4    CONTINUE
6305       ENDIF
6306
6307       RETURN
6308       END
6309
6310 *$ CREATE DT_GETPTN.FOR
6311 *COPY DT_GETPTN
6312 *
6313 *===getptn=============================================================*
6314 *
6315       SUBROUTINE DT_GETPTN(IP,NN,NCSY,IREJ)
6316
6317 ************************************************************************
6318 * This subroutine collects partons at chain ends from temporary        *
6319 * commons and puts them into DTEVT1.                                   *
6320 * This version dated 15.01.95 is written by S. Roesler                 *
6321 ************************************************************************
6322
6323       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6324       SAVE
6325
6326       PARAMETER ( LINP = 10 ,
6327      &            LOUT = 6 ,
6328      &            LDAT = 9 )
6329
6330       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0)
6331
6332       LOGICAL LCHK
6333
6334       PARAMETER ( MAXNCL = 260,
6335
6336      &            MAXVQU = MAXNCL,
6337      &            MAXSQU = 20*MAXVQU,
6338      &            MAXINT = MAXVQU+MAXSQU)
6339
6340 * event history
6341
6342       PARAMETER (NMXHKK=200000)
6343
6344       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6345      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6346      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6347
6348 * extended event history
6349       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6350      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6351      &                IHIST(2,NMXHKK)
6352
6353 * flags for input different options
6354       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6355       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6356      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6357
6358 * auxiliary common for chain system storage (DTUNUC 1.x)
6359       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
6360
6361 * statistics
6362       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
6363      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
6364      &                ICEVTG(8,0:30)
6365
6366 * flags for diffractive interactions (DTUNUC 1.x)
6367       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6368
6369 * x-values of partons (DTUNUC 1.x)
6370       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
6371      &                XTVQ(MAXVQU),XTVD(MAXVQU),
6372      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
6373      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
6374
6375 * flavors of partons (DTUNUC 1.x)
6376       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
6377      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
6378      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
6379      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
6380      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
6381      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
6382      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
6383
6384 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6385       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
6386      &                IXPV,IXPS,IXTV,IXTS,
6387      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
6388      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
6389      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
6390      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
6391      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
6392      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
6393      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
6394      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
6395
6396 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
6397       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
6398      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
6399
6400       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PP(4),PT(4)
6401
6402       DATA AMSS,AMVS,AMDS,AMVD,AMVV/0.4D0,2.0D0,2.0D0,2.5D0,2.0D0/
6403
6404       IREJ      = 0
6405       NCSY      = 0
6406       NPOINT(2) = NHKK+1
6407
6408 * sea-sea chains
6409       DO 10 I=1,NSS
6410          IF (ISKPCH(1,I).EQ.99) GOTO 10
6411          ICCHAI(1,1) = ICCHAI(1,1)+2
6412          IDXP = INTSS1(I)
6413          IDXT = INTSS2(I)
6414          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6415          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6416          DO 11 K=1,4
6417             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6418             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6419             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6420             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6421    11    CONTINUE
6422          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6423      &                                  +(PP1(3)+PT1(3))**2)
6424          ECH   = PP1(4)+PT1(4)
6425          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6426          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6427      &                                  +(PP2(3)+PT2(3))**2)
6428          ECH   = PP2(4)+PT2(4)
6429          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6430          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6431             AM1 = SQRT(AM1)
6432             AM2 = SQRT(AM2)
6433             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMSS)) THEN
6434 C              WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6435  5000          FORMAT(1X,'incon. chain mass SS: ',2I5,2E10.3)
6436             ENDIF
6437          ELSE
6438             WRITE(LOUT,5000) NEVHKK,I,AM1,AM2
6439          ENDIF
6440          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6441          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6442          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6443          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6444          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6445      &                                                    0,0,1)
6446          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6447      &                                                    0,0,1)
6448          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6449      &                                                    0,0,1)
6450          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6451      &                                                    0,0,1)
6452          NCSY = NCSY+1
6453    10 CONTINUE
6454
6455 * disea-sea chains
6456       DO 20 I=1,NDS
6457          IF (ISKPCH(2,I).EQ.99) GOTO 20
6458          ICCHAI(1,2) = ICCHAI(1,2)+2
6459          IDXP = INTDS1(I)
6460          IDXT = INTDS2(I)
6461          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6462          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6463          DO 21 K=1,4
6464             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6465             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6466             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6467             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6468    21    CONTINUE
6469          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6470      &                                  +(PP1(3)+PT1(3))**2)
6471          ECH   = PP1(4)+PT1(4)
6472          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6473          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6474      &                                  +(PP2(3)+PT2(3))**2)
6475          ECH   = PP2(4)+PT2(4)
6476          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6477          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6478             AM1 = SQRT(AM1)
6479             AM2 = SQRT(AM2)
6480             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6481 C              WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6482  5001          FORMAT(1X,'incon. chain mass DS: ',2I5,2E10.3)
6483             ENDIF
6484          ELSE
6485             WRITE(LOUT,5001) NEVHKK,I,AM1,AM2
6486          ENDIF
6487          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6488          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6489          IFT1 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6490          IFT2 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6491          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6492      &                                                    0,0,2)
6493          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6494      &                                                    0,0,2)
6495          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6496      &                                                    0,0,2)
6497          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6498      &                                                    0,0,2)
6499          NCSY = NCSY+1
6500    20 CONTINUE
6501
6502 * sea-disea chains
6503       DO 30 I=1,NSD
6504          IF (ISKPCH(3,I).EQ.99) GOTO 30
6505          ICCHAI(1,3) = ICCHAI(1,3)+2
6506          IDXP = INTSD1(I)
6507          IDXT = INTSD2(I)
6508          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6509          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6510          DO 31 K=1,4
6511             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6512             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6513             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6514             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6515    31    CONTINUE
6516          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6517      &                                  +(PP1(3)+PT1(3))**2)
6518          ECH   = PP1(4)+PT1(4)
6519          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6520          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6521      &                                  +(PP2(3)+PT2(3))**2)
6522          ECH   = PP2(4)+PT2(4)
6523          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6524          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6525             AM1 = SQRT(AM1)
6526             AM2 = SQRT(AM2)
6527             IF ((AM1.LT.AMDS).OR.(AM2.LT.AMDS)) THEN
6528 C              WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6529  5002          FORMAT(1X,'incon. chain mass SD: ',2I5,2E10.3)
6530             ENDIF
6531          ELSE
6532             WRITE(LOUT,5002) NEVHKK,I,AM1,AM2
6533          ENDIF
6534          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6535          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6536          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6537          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6538          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6539      &                                                    0,0,3)
6540          CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6541      &                                                    0,0,3)
6542          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6543      &                                                    0,0,3)
6544          CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6545      &                                                    0,0,3)
6546          NCSY = NCSY+1
6547    30 CONTINUE
6548
6549 * disea-valence chains
6550       DO 50 I=1,NDV
6551          IF (ISKPCH(5,I).EQ.99) GOTO 50
6552          ICCHAI(1,5) = ICCHAI(1,5)+2
6553          IDXP = INTDV1(I)
6554          IDXT = INTDV2(I)
6555          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6556          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6557          DO 51 K=1,4
6558             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6559             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6560             PT1(K) = XTVQ(IDXT) *PHKK(K,MOT)
6561             PT2(K) = XTVD(IDXT) *PHKK(K,MOT)
6562    51    CONTINUE
6563          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6564      &                                  +(PP1(3)+PT1(3))**2)
6565          ECH   = PP1(4)+PT1(4)
6566          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6567          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6568      &                                  +(PP2(3)+PT2(3))**2)
6569          ECH   = PP2(4)+PT2(4)
6570          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6571          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6572             AM1 = SQRT(AM1)
6573             AM2 = SQRT(AM2)
6574             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6575 C              WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6576  5003          FORMAT(1X,'incon. chain mass DV: ',2I5,2E10.3)
6577             ENDIF
6578          ELSE
6579             WRITE(LOUT,5003) NEVHKK,I,AM1,AM2
6580          ENDIF
6581          IFP1 = IDT_IB2PDG(IPSQ(IDXP),IPSQ2(IDXP),2)
6582          IFP2 = IDT_IB2PDG(-IPSQ(IDXP),-IPSQ2(IDXP),2)
6583          IFT1 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6584          IFT2 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6585          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6586      &                                                    0,0,5)
6587          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6588      &                                                    0,0,5)
6589          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6590      &                                                    0,0,5)
6591          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6592      &                                                    0,0,5)
6593          NCSY = NCSY+1
6594    50 CONTINUE
6595
6596 * valence-sea chains
6597       DO 60 I=1,NVS
6598          IF (ISKPCH(6,I).EQ.99) GOTO 60
6599          ICCHAI(1,6) = ICCHAI(1,6)+2
6600          IDXP = INTVS1(I)
6601          IDXT = INTVS2(I)
6602          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6603          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6604          DO 61 K=1,4
6605             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6606             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6607             PT1(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6608             PT2(K) = XTSQ(IDXT) *PHKK(K,MOT)
6609    61    CONTINUE
6610          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6611          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6612          IFT1 = IDT_IB2PDG(ITSAQ(IDXT),0,2)
6613          IFT2 = IDT_IB2PDG(ITSQ(IDXT),0,2)
6614          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6615          IF (LCHK) THEN
6616             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6617      &                                                       0,0,6)
6618             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6619      &                                                       0,0,6)
6620             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6621      &                                                       0,0,6)
6622             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6623      &                                                       0,0,6)
6624             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6625      &                                     +(PP1(3)+PT1(3))**2)
6626             ECH   = PP1(4)+PT1(4)
6627             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6628             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6629      &                                     +(PP2(3)+PT2(3))**2)
6630             ECH   = PP2(4)+PT2(4)
6631             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6632          ELSE
6633             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6634      &                                                       0,0,6)
6635             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6636      &                                                       0,0,6)
6637             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6638      &                                                       0,0,6)
6639             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6640      &                                                       0,0,6)
6641             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6642      &                                     +(PP1(3)+PT2(3))**2)
6643             ECH   = PP1(4)+PT2(4)
6644             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6645             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6646      &                                     +(PP2(3)+PT1(3))**2)
6647             ECH   = PP2(4)+PT1(4)
6648             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6649          ENDIF
6650          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6651             AM1 = SQRT(AM1)
6652             AM2 = SQRT(AM2)
6653             IF ((AM1.LT.AMSS).OR.(AM2.LT.AMVS)) THEN
6654 C              WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6655  5004          FORMAT(1X,'incon. chain mass VS: ',2I5,2E10.3)
6656             ENDIF
6657          ELSE
6658             WRITE(LOUT,5004) NEVHKK,I,AM1,AM2
6659          ENDIF
6660          NCSY = NCSY+1
6661    60 CONTINUE
6662
6663 * sea-valence chains
6664       DO 40 I=1,NSV
6665          IF (ISKPCH(4,I).EQ.99) GOTO 40
6666          ICCHAI(1,4) = ICCHAI(1,4)+2
6667          IDXP = INTSV1(I)
6668          IDXT = INTSV2(I)
6669          MOP  = JDAHKK(1,IPOSP(IFROSP(IDXP)))
6670          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6671          DO 41 K=1,4
6672             PP1(K) = XPSQ(IDXP) *PHKK(K,MOP)
6673             PP2(K) = XPSAQ(IDXP)*PHKK(K,MOP)
6674             PT1(K) = XTVD(IDXT) *PHKK(K,MOT)
6675             PT2(K) = XTVQ(IDXT) *PHKK(K,MOT)
6676    41    CONTINUE
6677          PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6678      &                                  +(PP1(3)+PT1(3))**2)
6679          ECH   = PP1(4)+PT1(4)
6680          AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6681          PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6682      &                                  +(PP2(3)+PT2(3))**2)
6683          ECH   = PP2(4)+PT2(4)
6684          AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6685          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6686             AM1 = SQRT(AM1)
6687             AM2 = SQRT(AM2)
6688             IF ((AM1.LT.AMVS).OR.(AM2.LT.AMSS)) THEN
6689 C              WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6690  5005          FORMAT(1X,'incon. chain mass SV: ',2I5,2E10.3)
6691             ENDIF
6692          ELSE
6693             WRITE(LOUT,5005) NEVHKK,I,AM1,AM2
6694          ENDIF
6695          IFP1 = IDT_IB2PDG(IPSQ(IDXP),0,2)
6696          IFP2 = IDT_IB2PDG(IPSAQ(IDXP),0,2)
6697          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6698          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6699          CALL DT_EVTPUT(-31,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6700      &                                                    0,0,4)
6701          CALL DT_EVTPUT(-22,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6702      &                                                    0,0,4)
6703          CALL DT_EVTPUT(-31,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6704      &                                                    0,0,4)
6705          CALL DT_EVTPUT(-22,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6706      &                                                    0,0,4)
6707          NCSY = NCSY+1
6708    40 CONTINUE
6709
6710 * valence-disea chains
6711       DO 70 I=1,NVD
6712          IF (ISKPCH(7,I).EQ.99) GOTO 70
6713          ICCHAI(1,7) = ICCHAI(1,7)+2
6714          IDXP = INTVD1(I)
6715          IDXT = INTVD2(I)
6716          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6717          MOT  = JDAHKK(1,IPOST(IFROST(IDXT)))
6718          DO 71 K=1,4
6719             PP1(K) = XPVQ(IDXP) *PHKK(K,MOP)
6720             PP2(K) = XPVD(IDXP) *PHKK(K,MOP)
6721             PT1(K) = XTSQ(IDXT) *PHKK(K,MOT)
6722             PT2(K) = XTSAQ(IDXT)*PHKK(K,MOT)
6723    71    CONTINUE
6724          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6725          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6726          IFT1 = IDT_IB2PDG(ITSQ(IDXT),ITSQ2(IDXT),2)
6727          IFT2 = IDT_IB2PDG(-ITSQ(IDXT),-ITSQ2(IDXT),2)
6728          CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6729          IF (LCHK) THEN
6730             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6731      &                                                       0,0,7)
6732             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6733      &                                                       0,0,7)
6734             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6735      &                                                       0,0,7)
6736             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6737      &                                                       0,0,7)
6738             PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6739      &                                     +(PP1(3)+PT1(3))**2)
6740             ECH   = PP1(4)+PT1(4)
6741             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6742             PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6743      &                                     +(PP2(3)+PT2(3))**2)
6744             ECH   = PP2(4)+PT2(4)
6745             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6746          ELSE
6747             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
6748      &                                                       0,0,7)
6749             CALL DT_EVTPUT(-32,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
6750      &                                                       0,0,7)
6751             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
6752      &                                                       0,0,7)
6753             CALL DT_EVTPUT(-32,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
6754      &                                                       0,0,7)
6755             PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6756      &                                     +(PP1(3)+PT2(3))**2)
6757             ECH   = PP1(4)+PT2(4)
6758             AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6759             PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6760      &                                     +(PP2(3)+PT1(3))**2)
6761             ECH   = PP2(4)+PT1(4)
6762             AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6763          ENDIF
6764          IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6765             AM1 = SQRT(AM1)
6766             AM2 = SQRT(AM2)
6767             IF ((AM1.LT.AMVD).OR.(AM2.LT.AMVD)) THEN
6768 C              WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6769  5006          FORMAT(1X,'incon. chain mass VD: ',2I5,2E10.3)
6770             ENDIF
6771          ELSE
6772             WRITE(LOUT,5006) NEVHKK,I,AM1,AM2
6773          ENDIF
6774          NCSY = NCSY+1
6775    70 CONTINUE
6776
6777 * valence-valence chains
6778       DO 80 I=1,NVV
6779          IF (ISKPCH(8,I).EQ.99) GOTO 80
6780          ICCHAI(1,8) = ICCHAI(1,8)+2
6781          IDXP = INTVV1(I)
6782          IDXT = INTVV2(I)
6783          MOP  = JDAHKK(1,IPOSP(IFROVP(IDXP)))
6784          MOT  = JDAHKK(1,IPOST(IFROVT(IDXT)))
6785          DO 81 K=1,4
6786             PP1(K) = XPVQ(IDXP)*PHKK(K,MOP)
6787             PP2(K) = XPVD(IDXP)*PHKK(K,MOP)
6788             PT1(K) = XTVD(IDXT)*PHKK(K,MOT)
6789             PT2(K) = XTVQ(IDXT)*PHKK(K,MOT)
6790    81    CONTINUE
6791          IFP1 = IDT_IB2PDG(IPVQ(IDXP),0,2)
6792          IFP2 = IDT_IB2PDG(IPPV1(IDXP),IPPV2(IDXP),2)
6793          IFT1 = IDT_IB2PDG(ITTV1(IDXT),ITTV2(IDXT),2)
6794          IFT2 = IDT_IB2PDG(ITVQ(IDXT),0,2)
6795
6796 * check for diffractive event
6797          IDIFF = 0
6798          IF (((ISINGD.GT.0).OR.(IDOUBD.GT.0)).AND.
6799      &        (IP.EQ.1).AND.(NN.EQ.1)) THEN
6800             DO 800 K=1,4
6801                PP(K) = PP1(K)+PP2(K)
6802                PT(K) = PT1(K)+PT2(K)
6803   800       CONTINUE
6804             ISTCK = NHKK
6805             CALL DT_DIFEVT(IFP1,IFP2,PP,MOP,
6806      &                  IFT1,IFT2,PT,MOT,IDIFF,NCSY,IREJ1)
6807 C           IF (IREJ1.NE.0) GOTO 9999
6808             IF (IREJ1.NE.0) THEN
6809                IDIFF = 0
6810                NHKK  = ISTCK
6811             ENDIF
6812          ELSE
6813             IDIFF = 0
6814          ENDIF
6815
6816          IF (IDIFF.EQ.0) THEN
6817 *   valence-valence chain system
6818             CALL  DT_CHKCSY(IFP1,IFT1,LCHK)
6819             IF (LCHK) THEN
6820 *    baryon-baryon
6821                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6822      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6823                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6824      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6825                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6826      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6827                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6828      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6829                PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
6830      &                                        +(PP1(3)+PT1(3))**2)
6831                ECH   = PP1(4)+PT1(4)
6832                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6833                PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
6834      &                                        +(PP2(3)+PT2(3))**2)
6835                ECH   = PP2(4)+PT2(4)
6836                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6837             ELSE
6838 *    antibaryon-baryon
6839                CALL DT_EVTPUT(-21,IFP1,MOP,0,
6840      &                     PP1(1),PP1(2),PP1(3),PP1(4),0,0,8)
6841                CALL DT_EVTPUT(-22,IFT2,MOT,0,
6842      &                     PT2(1),PT2(2),PT2(3),PT2(4),0,0,8)
6843                CALL DT_EVTPUT(-21,IFP2,MOP,0,
6844      &                     PP2(1),PP2(2),PP2(3),PP2(4),0,0,8)
6845                CALL DT_EVTPUT(-22,IFT1,MOT,0,
6846      &                     PT1(1),PT1(2),PT1(3),PT1(4),0,0,8)
6847                PTOCH = SQRT((PP1(1)+PT2(1))**2+(PP1(2)+PT2(2))**2
6848      &                                        +(PP1(3)+PT2(3))**2)
6849                ECH   = PP1(4)+PT2(4)
6850                AM1   = (ECH+PTOCH)*(ECH-PTOCH)
6851                PTOCH = SQRT((PP2(1)+PT1(1))**2+(PP2(2)+PT1(2))**2
6852      &                                        +(PP2(3)+PT1(3))**2)
6853                ECH   = PP2(4)+PT1(4)
6854                AM2   = (ECH+PTOCH)*(ECH-PTOCH)
6855             ENDIF
6856             IF ((AM1.GT.0.0D0).AND.(AM2.GT.0.0D0)) THEN
6857                AM1 = SQRT(AM1)
6858                AM2 = SQRT(AM2)
6859                IF ((AM1.LT.AMVV).OR.(AM2.LT.AMVV)) THEN
6860 C                 WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6861  5007             FORMAT(1X,'incon. chain mass VV: ',2I5,2E10.3)
6862                ENDIF
6863             ELSE
6864                WRITE(LOUT,5007) NEVHKK,I,AM1,AM2
6865             ENDIF
6866             NCSY = NCSY+1
6867          ENDIF
6868    80 CONTINUE
6869       IF (ISTHKK(NPOINT(2)).EQ.1) NPOINT(2) = NPOINT(2)+1
6870
6871 * energy-momentum & flavor conservation check
6872       IF (ABS(IDIFF).NE.1) THEN
6873          IF (IDIFF.NE.0) THEN
6874             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-41,1,0,
6875      &                                              1,3,10,IREJ)
6876          ELSE
6877             IF (LEMCCK) CALL DT_EMC2(9,10,0,0,0,3,-21,-22,-31,-32,0,
6878      &                                              1,3,10,IREJ)
6879          ENDIF
6880          IF (IREJ.NE.0) THEN
6881             CALL DT_EVTOUT(4)
6882             STOP
6883          ENDIF
6884       ENDIF
6885
6886       RETURN
6887
6888  9999 CONTINUE
6889       IREJ  = 1
6890       RETURN
6891       END
6892
6893 *$ CREATE DT_CHKCSY.FOR
6894 *COPY DT_CHKCSY
6895 *
6896 *===chkcsy=============================================================*
6897 *
6898       SUBROUTINE DT_CHKCSY(ID1,ID2,LCHK)
6899
6900 ************************************************************************
6901 * CHeCk Chain SYstem for consistency of partons at chain ends.         *
6902 *            ID1,ID2        PDG-numbers of partons at chain ends       *
6903 *            LCHK = .true.  consistent chain                           *
6904 *                 = .false. inconsistent chain                         *
6905 * This version dated 18.01.95 is written by S. Roesler                 *
6906 ************************************************************************
6907
6908       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6909       SAVE
6910
6911       PARAMETER ( LINP = 10 ,
6912      &            LOUT = 6 ,
6913      &            LDAT = 9 )
6914
6915       LOGICAL LCHK
6916
6917       LCHK = .TRUE.
6918
6919 * q-aq chain
6920       IF ((ABS(ID1).LE.6).AND.(ABS(ID2).LE.6)) THEN
6921          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6922 * q-qq, aq-aqaq chain
6923       ELSEIF (((ABS(ID1).LE.6).AND.(ABS(ID2).GT.6)).OR.
6924      &        ((ABS(ID1).GT.6).AND.(ABS(ID2).LE.6))) THEN
6925          IF (ID1*ID2.LT.0) LCHK = .FALSE.
6926 * qq-aqaq chain
6927       ELSEIF ((ABS(ID1).GT.6).AND.(ABS(ID2).GT.6)) THEN
6928          IF (ID1*ID2.GT.0) LCHK = .FALSE.
6929       ENDIF
6930
6931       RETURN
6932       END
6933
6934 *$ CREATE DT_EVENTA.FOR
6935 *COPY DT_EVENTA
6936 *
6937 *===eventa=============================================================*
6938 *
6939       SUBROUTINE DT_EVENTA(ID,IP,IT,NCSY,IREJ)
6940
6941 ************************************************************************
6942 * Treatment of nucleon-nucleon interactions in a two-chain             *
6943 * approximation.                                                       *
6944 *  (input) ID       BAMJET-index of projectile hadron (in case of      *
6945 *                   h-K scattering)                                    *
6946 *          IP/IT    mass number of projectile/target nucleus           *
6947 *          NCSY     number of two chain systems                        *
6948 *          IREJ     rejection flag                                     *
6949 * This version dated 15.01.95 is written by S. Roesler                 *
6950 ************************************************************************
6951
6952       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
6953       SAVE
6954
6955       PARAMETER ( LINP = 10 ,
6956      &            LOUT = 6 ,
6957      &            LDAT = 9 )
6958
6959       PARAMETER (TINY10=1.0D-10)
6960
6961 * event history
6962
6963       PARAMETER (NMXHKK=200000)
6964
6965       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
6966      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
6967      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
6968
6969 * extended event history
6970       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
6971      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
6972      &                IHIST(2,NMXHKK)
6973
6974 * rejection counter
6975       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
6976      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
6977      &                IREXCI(3),IRDIFF(2),IRINC
6978
6979 * flags for diffractive interactions (DTUNUC 1.x)
6980       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
6981
6982 * particle properties (BAMJET index convention)
6983       CHARACTER*8  ANAME
6984       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
6985      &                IICH(210),IIBAR(210),K1(210),K2(210)
6986
6987 * flags for input different options
6988       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
6989       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
6990      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
6991
6992 * various options for treatment of partons (DTUNUC 1.x)
6993 * (chain recombination, Cronin,..)
6994       LOGICAL LCO2CR,LINTPT
6995       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
6996      &                LCO2CR,LINTPT
6997
6998       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
6999
7000       IREJ      = 0
7001       NPOINT(3) = NHKK+1
7002
7003 * skip following treatment for low-mass diffraction
7004       IF (ABS(IFLAGD).EQ.1) THEN
7005          NPOINT(3) = NPOINT(2)
7006          GOTO 5
7007       ENDIF
7008
7009 * multiple scattering of chain ends
7010       IF ((IP.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(1)
7011       IF ((IT.GT.1).AND.(MKCRON.NE.0)) CALL DT_CRONIN(2)
7012
7013       NC = NPOINT(2)
7014 * get a two-chain system from DTEVT1
7015       DO 3 I=1,NCSY
7016          IFP1 = IDHKK(NC)
7017          IFT1 = IDHKK(NC+1)
7018          IFP2 = IDHKK(NC+2)
7019          IFT2 = IDHKK(NC+3)
7020          DO 4 K=1,4
7021             PP1(K) = PHKK(K,NC)
7022             PT1(K) = PHKK(K,NC+1)
7023             PP2(K) = PHKK(K,NC+2)
7024             PT2(K) = PHKK(K,NC+3)
7025     4    CONTINUE
7026          MOP1 = NC
7027          MOT1 = NC+1
7028          MOP2 = NC+2
7029          MOT2 = NC+3
7030          CALL DT_GETCSY(IFP1,PP1,MOP1,IFP2,PP2,MOP2,
7031      &               IFT1,PT1,MOT1,IFT2,PT2,MOT2,IREJ1)
7032          IF (IREJ1.GT.0) THEN
7033             IRHHA = IRHHA+1
7034             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in EVENTA'
7035             GOTO 9999
7036          ENDIF
7037          NC = NC+4
7038     3 CONTINUE
7039
7040 * meson/antibaryon projectile:
7041 * sample single-chain valence-valence systems (Reggeon contrib.)
7042       IF ((IP.EQ.1).AND.(ISICHA.EQ.1)) THEN
7043          IF (IIBAR(ID).LE.0) CALL DT_VV2SCH
7044       ENDIF
7045
7046       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7047 * check DTEVT1 for remaining resonance mass corrections
7048          CALL DT_EVTRES(IREJ1)
7049          IF (IREJ1.GT.0) THEN
7050             IRRES(1) = IRRES(1)+1
7051             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 2 in EVENTA'
7052             GOTO 9999
7053          ENDIF
7054       ENDIF
7055
7056 * assign p_t to two-"chain" systems consisting of two resonances only
7057 * since only entries for chains will be affected, this is obsolete
7058 * in case of JETSET-fragmetation
7059       CALL DT_RESPT
7060
7061 * combine q-aq chains to color ropes (qq-aqaq) (chain fusion)
7062       IF (LCO2CR) CALL DT_COM2CR
7063
7064     5 CONTINUE
7065
7066 * fragmentation of the complete event
7067 **uncomment for internal phojet-fragmentation
7068 C     CALL DT_EVTFRA(IREJ1)
7069       CALL DT_EVTFRG(2,IDUM,NPYMEM,IREJ1)
7070       IF (IREJ1.GT.0) THEN
7071          IRFRAG = IRFRAG+1
7072          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 3 in EVENTA'
7073          GOTO 9999
7074       ENDIF
7075
7076 * decay of possible resonances (should be obsolete)
7077       CALL DT_DECAY1
7078
7079       RETURN
7080
7081  9999 CONTINUE
7082       IREVT = IREVT+1
7083       IREJ  = 1
7084       RETURN
7085       END
7086
7087 *$ CREATE DT_GETCSY.FOR
7088 *COPY DT_GETCSY
7089 *
7090 *===getcsy=============================================================*
7091 *
7092       SUBROUTINE DT_GETCSY(IFPR1,PP1,MOP1,IFPR2,PP2,MOP2,
7093      &                  IFTA1,PT1,MOT1,IFTA2,PT2,MOT2,IREJ)
7094
7095 ************************************************************************
7096 * This version dated 15.01.95 is written by S. Roesler                 *
7097 ************************************************************************
7098
7099       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7100       SAVE
7101
7102       PARAMETER ( LINP = 10 ,
7103      &            LOUT = 6 ,
7104      &            LDAT = 9 )
7105
7106       PARAMETER (TINY10=1.0D-10)
7107
7108 * event history
7109
7110       PARAMETER (NMXHKK=200000)
7111
7112       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7113      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7114      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7115
7116 * extended event history
7117       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7118      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7119      &                IHIST(2,NMXHKK)
7120
7121 * rejection counter
7122       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7123      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7124      &                IREXCI(3),IRDIFF(2),IRINC
7125
7126 * flags for input different options
7127       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7128       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7129      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7130
7131 * flags for diffractive interactions (DTUNUC 1.x)
7132       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
7133
7134       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),
7135      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),PCH1(4),PCH2(4)
7136
7137       IREJ  = 0
7138
7139 * get quark content of partons
7140       DO 1 I=1,2
7141          IFP1(I) = 0
7142          IFP2(I) = 0
7143          IFT1(I) = 0
7144          IFT2(I) = 0
7145     1 CONTINUE
7146       IFP1(1) = IDT_IPDG2B(IFPR1,1,2)
7147       IF (ABS(IFPR1).GE.1000) IFP1(2) = IDT_IPDG2B(IFPR1,2,2)
7148       IFP2(1) = IDT_IPDG2B(IFPR2,1,2)
7149       IF (ABS(IFPR2).GE.1000) IFP2(2) = IDT_IPDG2B(IFPR2,2,2)
7150       IFT1(1) = IDT_IPDG2B(IFTA1,1,2)
7151       IF (ABS(IFTA1).GE.1000) IFT1(2) = IDT_IPDG2B(IFTA1,2,2)
7152       IFT2(1) = IDT_IPDG2B(IFTA2,1,2)
7153       IF (ABS(IFTA2).GE.1000) IFT2(2) = IDT_IPDG2B(IFTA2,2,2)
7154
7155 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq, 3 - qq-aqaq)
7156       IDCH1 = 2
7157       IF ((IFP1(2).EQ.0).AND.(IFT1(2).EQ.0)) IDCH1 = 1
7158       IF ((IFP1(2).NE.0).AND.(IFT1(2).NE.0)) IDCH1 = 3
7159       IDCH2 = 2
7160       IF ((IFP2(2).EQ.0).AND.(IFT2(2).EQ.0)) IDCH2 = 1
7161       IF ((IFP2(2).NE.0).AND.(IFT2(2).NE.0)) IDCH2 = 3
7162
7163 * store initial configuration for energy-momentum cons. check
7164       IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IDUM)
7165
7166 * sample intrinsic p_t at chain-ends
7167       CALL DT_GETSPT(PP1,IFPR1,IFP1,PP2,IFPR2,IFP2,
7168      &            PT1,IFTA1,IFT1,PT2,IFTA2,IFT2,
7169      &            AMCH1,IDCH1,AMCH2,IDCH2,IDCH(MOP1),IREJ1)
7170       IF (IREJ1.NE.0) THEN
7171          IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in GETCSY'
7172          IRPT = IRPT+1
7173          GOTO 9999
7174       ENDIF
7175
7176 C      IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7177 C         IF ((IDCH1.EQ.3).OR.((IDCH1.GT.1).AND.(IDCH2.EQ.1))) THEN
7178 C* check second chain for resonance
7179 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7180 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
7181 C            IF (IREJ1.NE.0) GOTO 9999
7182 C            IF (IDR2.NE.0) THEN
7183 C               CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7184 C     &                     AMCH2,AMCH2N,AMCH1,IREJ1)
7185 C               IF (IREJ1.NE.0) GOTO 9999
7186 C            ENDIF
7187 C* check first chain for resonance
7188 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7189 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
7190 C            IF (IREJ1.NE.0) GOTO 9999
7191 C            IF (IDR1.NE.0) IDR1 = 100*IDR1
7192 C         ELSE
7193 C* check first chain for resonance
7194 C            CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7195 C     &                  AMCH1,AMCH1N,IDCH1,IREJ1)
7196 C            IF (IREJ1.NE.0) GOTO 9999
7197 C            IF (IDR1.NE.0) THEN
7198 C               CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7199 C     &                     AMCH1,AMCH1N,AMCH2,IREJ1)
7200 C               IF (IREJ1.NE.0) GOTO 9999
7201 C            ENDIF
7202 C* check second chain for resonance
7203 C            CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7204 C     &                  AMCH2,AMCH2N,IDCH2,IREJ1)
7205 C            IF (IREJ1.NE.0) GOTO 9999
7206 C            IF (IDR2.NE.0) IDR2 = 100*IDR2
7207 C         ENDIF
7208 C      ENDIF
7209
7210       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
7211 * check chains for resonances
7212          CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7213      &               AMCH1,AMCH1N,IDCH1,IREJ1)
7214          IF (IREJ1.NE.0) GOTO 9999
7215          CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7216      &               AMCH2,AMCH2N,IDCH2,IREJ1)
7217          IF (IREJ1.NE.0) GOTO 9999
7218 * change kinematics corresponding to resonance-masses
7219          IF ( (IDR1.NE.0).AND.(IDR2.EQ.0) ) THEN
7220             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7221      &                                 AMCH1,AMCH1N,AMCH2,IREJ1)
7222             IF (IREJ1.GT.0) GOTO 9999
7223             IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7224             CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDR2,IDXR2,
7225      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
7226             IF (IREJ1.NE.0) GOTO 9999
7227             IF (IDR2.NE.0) IDR2 = 100*IDR2
7228          ELSEIF ( (IDR1.EQ.0).AND.(IDR2.NE.0) ) THEN
7229             CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7230      &                                 AMCH2,AMCH2N,AMCH1,IREJ1)
7231             IF (IREJ1.GT.0) GOTO 9999
7232             IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7233             CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDR1,IDXR1,
7234      &                  AMCH1,AMCH1N,IDCH1,IREJ1)
7235             IF (IREJ1.NE.0) GOTO 9999
7236             IF (IDR1.NE.0) IDR1 = 100*IDR1
7237          ELSEIF ( (IDR1.NE.0).AND.(IDR2.NE.0) ) THEN
7238             AMDIF1 = ABS(AMCH1-AMCH1N)
7239             AMDIF2 = ABS(AMCH2-AMCH2N)
7240             IF (AMDIF2.LT.AMDIF1) THEN
7241                CALL DT_CHKINE(PP2,IFPR2,PP1,IFPR1,PT2,IFTA2,PT1,IFTA1,
7242      &                                    AMCH2,AMCH2N,AMCH1,IREJ1)
7243                IF (IREJ1.GT.0) GOTO 9999
7244                IF (IREJ1.EQ.-1) IDR2 = 100*IDR2
7245                CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),
7246      &                     IDR1,IDXR1,AMCH1,AMCH1N,IDCH1,IREJ1)
7247                IF (IREJ1.NE.0) GOTO 9999
7248                IF (IDR1.NE.0) IDR1 = 100*IDR1
7249             ELSE
7250                CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
7251      &                                    AMCH1,AMCH1N,AMCH2,IREJ1)
7252                IF (IREJ1.GT.0) GOTO 9999
7253                IF (IREJ1.EQ.-1) IDR1 = 100*IDR1
7254                CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),
7255      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCH2,IREJ1)
7256                IF (IREJ1.NE.0) GOTO 9999
7257                IF (IDR2.NE.0) IDR2 = 100*IDR2
7258             ENDIF
7259          ENDIF
7260       ENDIF
7261
7262 * store final configuration for energy-momentum cons. check
7263       IF (LEMCCK) THEN
7264          CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IDUM)
7265          CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
7266          IF (IREJ1.NE.0) GOTO 9999
7267       ENDIF
7268
7269 * put partons and chains into DTEVT1
7270       DO 10 I=1,4
7271          PCH1(I) = PP1(I)+PT1(I)
7272          PCH2(I) = PP2(I)+PT2(I)
7273    10 CONTINUE
7274       CALL DT_EVTPUT(-ISTHKK(MOP1),IFPR1,MOP1,0,PP1(1),PP1(2),
7275      &                                      PP1(3),PP1(4),0,0,0)
7276       CALL DT_EVTPUT(-ISTHKK(MOT1),IFTA1,MOT1,0,PT1(1),PT1(2),
7277      &                                      PT1(3),PT1(4),0,0,0)
7278       KCH = 100+IDCH(MOP1)*10+1
7279       CALL DT_EVTPUT(KCH,88888,-2,-1,
7280      &           PCH1(1),PCH1(2),PCH1(3),PCH1(4),IDR1,IDXR1,IDCH(MOP1))
7281       CALL DT_EVTPUT(-ISTHKK(MOP2),IFPR2,MOP2,0,PP2(1),PP2(2),
7282      &                                      PP2(3),PP2(4),0,0,0)
7283       CALL DT_EVTPUT(-ISTHKK(MOT2),IFTA2,MOT2,0,PT2(1),PT2(2),
7284      &                                      PT2(3),PT2(4),0,0,0)
7285       KCH = KCH+1
7286       CALL DT_EVTPUT(KCH,88888,-2,-1,
7287      &           PCH2(1),PCH2(2),PCH2(3),PCH2(4),IDR2,IDXR2,IDCH(MOP2))
7288
7289       RETURN
7290
7291  9999 CONTINUE
7292       IF ((IDCH(MOP1).LE.3).AND.(IDCH(MOP2).LE.3)) THEN
7293 * "cancel" sea-sea chains
7294          CALL DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ1)
7295          IF (IREJ1.NE.0) GOTO 9998
7296 **sr 16.5. flag for EVENTB
7297          IREJ = -1
7298          RETURN
7299       ENDIF
7300  9998 CONTINUE
7301       IREJ = 1
7302       RETURN
7303       END
7304
7305 *$ CREATE DT_CHKINE.FOR
7306 *COPY DT_CHKINE
7307 *
7308 *===chkine=============================================================*
7309 *
7310       SUBROUTINE DT_CHKINE(PP1I,IFP1,PP2I,IFP2,PT1I,IFT1,PT2I,IFT2,
7311      &                  AMCH1,AMCH1N,AMCH2,IREJ)
7312
7313 ************************************************************************
7314 * This subroutine replaces CORMOM.                                     *
7315 * This version dated 05.01.95 is written by S. Roesler                 *
7316 ************************************************************************
7317
7318       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7319       SAVE
7320
7321       PARAMETER ( LINP = 10 ,
7322      &            LOUT = 6 ,
7323      &            LDAT = 9 )
7324
7325       PARAMETER (TINY10=1.0D-10)
7326
7327 * flags for input different options
7328       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7329       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7330      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7331
7332 * rejection counter
7333       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7334      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7335      &                IREXCI(3),IRDIFF(2),IRINC
7336
7337       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),P1(4),P2(4),
7338      &          PP1I(4),PP2I(4),PT1I(4),PT2I(4)
7339
7340       IREJ  = 0
7341       JMSHL = IMSHL
7342
7343       SCALE  = AMCH1N/MAX(AMCH1,TINY10)
7344       DO 10 I=1,4
7345          PP1(I) = PP1I(I)
7346          PP2(I) = PP2I(I)
7347          PT1(I) = PT1I(I)
7348          PT2(I) = PT2I(I)
7349          PP2(I) = PP2(I)+(1.0D0-SCALE)*PP1(I)
7350          PT2(I) = PT2(I)+(1.0D0-SCALE)*PT1(I)
7351          PP1(I) = SCALE*PP1(I)
7352          PT1(I) = SCALE*PT1(I)
7353    10 CONTINUE
7354       IF ((PP1(4).LT.0.0D0).OR.(PP2(4).LT.0.0D0).OR.
7355      &    (PT1(4).LT.0.0D0).OR.(PT2(4).LT.0.0D0)) GOTO 9997
7356
7357       ECH = PP2(4)+PT2(4)
7358       PCH = SQRT( (PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2+
7359      &                               (PP2(3)+PT2(3))**2 )
7360       AMCH22 = (ECH-PCH)*(ECH+PCH)
7361       IF (AMCH22.LT.0.0D0) THEN
7362          IF (IOULEV(1).GT.0)
7363      &      WRITE(LOUT,'(1X,A)') 'CHKINE: inconsistent treatment!'
7364          GOTO 9997
7365       ENDIF
7366
7367       AMCH1 = AMCH1N
7368       AMCH2 = SQRT(AMCH22)
7369
7370 * put partons again on mass shell
7371    13 CONTINUE
7372       XM1 = 0.0D0
7373       XM2 = 0.0D0
7374       IF (JMSHL.EQ.1) THEN
7375
7376          XM1 = PYMASS(IFP1)
7377          XM2 = PYMASS(IFT1)
7378
7379       ENDIF
7380       CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
7381       IF (IREJ1.NE.0) THEN
7382          IF (JMSHL.EQ.0) GOTO 9998
7383          JMSHL = 0
7384          GOTO 13
7385       ENDIF
7386       JMSHL = IMSHL
7387       DO 11 I=1,4
7388          PP1(I) = P1(I)
7389          PT1(I) = P2(I)
7390    11 CONTINUE
7391    14 CONTINUE
7392       XM1 = 0.0D0
7393       XM2 = 0.0D0
7394       IF (JMSHL.EQ.1) THEN
7395
7396          XM1 = PYMASS(IFP2)
7397          XM2 = PYMASS(IFT2)
7398
7399       ENDIF
7400       CALL DT_MASHEL(PP2,PT2,XM1,XM2,P1,P2,IREJ1)
7401       IF (IREJ1.NE.0) THEN
7402          IF (JMSHL.EQ.0) GOTO 9998
7403          JMSHL = 0
7404          GOTO 14
7405       ENDIF
7406       DO 12 I=1,4
7407          PP2(I) = P1(I)
7408          PT2(I) = P2(I)
7409    12 CONTINUE
7410       DO 15 I=1,4
7411          PP1I(I) = PP1(I)
7412          PP2I(I) = PP2(I)
7413          PT1I(I) = PT1(I)
7414          PT2I(I) = PT2(I)
7415    15 CONTINUE
7416       RETURN
7417
7418  9997 IRCHKI(1) = IRCHKI(1)+1
7419 **sr
7420 C     GOTO 9999
7421       IREJ = -1
7422       RETURN
7423 **
7424  9998 IRCHKI(2) = IRCHKI(2)+1
7425
7426  9999 CONTINUE
7427       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in CHKINE'
7428       IREJ = 1
7429       RETURN
7430       END
7431
7432 *$ CREATE DT_CH2RES.FOR
7433 *COPY DT_CH2RES
7434 *
7435 *===ch2res=============================================================*
7436 *
7437       SUBROUTINE DT_CH2RES(IF1,IF2,IF3,IF4,IDR,IDXR,
7438      &                  AM,AMN,IMODE,IREJ)
7439
7440 ************************************************************************
7441 * Check chains for resonance production.                               *
7442 * This subroutine replaces COMCMA/COBCMA/COMCM2                        *
7443 *    input:                                                            *
7444 *          IF1,2,3,4    input flavors (q,aq in any order)              *
7445 *          AM           chain mass                                     *
7446 *          MODE = 1     check q-aq chain for meson-resonance           *
7447 *               = 2     check q-qq, aq-aqaq chain for baryon-resonance *
7448 *               = 3     check qq-aqaq chain for lower mass cut         *
7449 *    output:                                                           *
7450 *          IDR = 0      no resonances found                            *
7451 *              = -1     pseudoscalar meson/octet baryon                *
7452 *              = 1      vector-meson/decuplet baryon                   *
7453 *          IDXR         BAMJET-index of corresponding resonance        *
7454 *          AMN          mass of corresponding resonance                *
7455 *                                                                      *
7456 *          IREJ         rejection flag                                 *
7457 * This version dated 06.01.95 is written by S. Roesler                 *
7458 ************************************************************************
7459
7460       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7461       SAVE
7462
7463       PARAMETER ( LINP = 10 ,
7464      &            LOUT = 6 ,
7465      &            LDAT = 9 )
7466
7467 * particle properties (BAMJET index convention)
7468       CHARACTER*8  ANAME
7469       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7470      &                IICH(210),IIBAR(210),K1(210),K2(210)
7471
7472 * quark-content to particle index conversion (DTUNUC 1.x)
7473       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
7474      &                IA08(6,21),IA10(6,21)
7475
7476 * rejection counter
7477       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
7478      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
7479      &                IREXCI(3),IRDIFF(2),IRINC
7480
7481 * flags for input different options
7482       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7483       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7484      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7485
7486       DIMENSION IF(4),JF(4)
7487
7488 **sr 4.7. test
7489 C     DATA AMLOM,AMLOB /0.08D0,0.2D0/
7490       DATA AMLOM,AMLOB /0.1D0,0.7D0/
7491 **
7492 C     DATA AMLOM,AMLOB /0.001D0,0.001D0/
7493
7494       MODE = ABS(IMODE)
7495
7496       IF ((MODE.LT.1).OR.(MODE.GT.3)) THEN
7497          WRITE(LOUT,1000) MODE
7498  1000    FORMAT(1X,'CH2RES: MODE ',I4,' not supported!',/,
7499      &          1X,'        program stopped')
7500          STOP
7501       ENDIF
7502
7503       AMX  = AM
7504       IREJ = 0
7505       IDR  = 0
7506       IDXR = 0
7507       AMN  = AMX
7508       IF ((AM.LE.0.0D0).AND.(MODE.EQ.1)) AMX = AMLOM
7509       IF ((AM.LE.0.0D0).AND.(MODE.EQ.2)) AMX = AMLOB
7510
7511       IF(1) = IF1
7512       IF(2) = IF2
7513       IF(3) = IF3
7514       IF(4) = IF4
7515       NF = 0
7516       DO 100 I=1,4
7517          IF (IF(I).NE.0) THEN
7518             NF = NF+1
7519             JF(NF) = IF(I)
7520          ENDIF
7521   100 CONTINUE
7522       IF (NF.LE.MODE) THEN
7523          WRITE(LOUT,1001) MODE,IF
7524  1001    FORMAT(1X,'CH2RES: inconsistent input flavors in MODE ',
7525      &   I4,' IF1 = ',I4,' IF2 = ',I4,' IF3 = ',I4,' IF4 = ',I4)
7526          GOTO 9999
7527       ENDIF
7528
7529       GOTO (1,2,3) MODE
7530
7531 * check for meson resonance
7532     1 CONTINUE
7533       IFQ  = JF(1)
7534       IFAQ = ABS(JF(2))
7535       IF (JF(2).GT.0) THEN
7536          IFQ  = JF(2)
7537          IFAQ = ABS(JF(1))
7538       ENDIF
7539       IFPS = IMPS(IFAQ,IFQ)
7540       IFV  = IMVE(IFAQ,IFQ)
7541       AMPS = AAM(IFPS)
7542       AMV  = AAM(IFV)
7543       AMHI = AMV+0.3D0
7544       IF (AMX.LT.AMV) THEN
7545          IF (AMX.LT.AMPS) THEN
7546             IF (IMODE.GT.0) THEN
7547                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOM)) GOTO 9999
7548             ELSE
7549                IF (AMX.LT.0.8D0*AMPS) GOTO 9999
7550             ENDIF
7551             LOMRES = LOMRES+1
7552          ENDIF
7553 *    replace chain by pseudoscalar meson
7554          IDR  = -1
7555          IDXR = IFPS
7556          AMN  = AMPS
7557       ELSEIF (AMX.LT.AMHI) THEN
7558 *    replace chain by vector-meson
7559          IDR  = 1
7560          IDXR = IFV
7561          AMN  = AMV
7562       ENDIF
7563       RETURN
7564
7565 * check for baryon resonance
7566     2 CONTINUE
7567       CALL DT_DBKLAS(JF(1),JF(2),JF(3),JB8,JB10)
7568       AM8  = AAM(JB8)
7569       AM10 = AAM(JB10)
7570       AMHI = AM10+0.3D0
7571       IF (AMX.LT.AM10) THEN
7572          IF (AMX.LT.AM8) THEN
7573             IF (IMODE.GT.0) THEN
7574                IF ((IRESRJ.EQ.1).OR.(AMX.LT.AMLOB)) GOTO 9999
7575             ELSE
7576                IF (AMX.LT.0.8D0*AM8) GOTO 9999
7577             ENDIF
7578             LOBRES = LOBRES+1
7579          ENDIF
7580 *    replace chain by oktet baryon
7581          IDR  = -1
7582          IDXR = JB8
7583          AMN  = AM8
7584       ELSEIF (AMX.LT.AMHI) THEN
7585          IDR  = 1
7586          IDXR = JB10
7587          AMN  = AM10
7588       ENDIF
7589       RETURN
7590
7591 * check qq-aqaq for lower mass cut
7592     3 CONTINUE
7593 *   empirical definition of AMHI to allow for (b-antib)-pair prod.
7594       AMHI = 2.5D0
7595       IF (AMX.LT.AMHI) GOTO 9999
7596       RETURN
7597
7598  9999 CONTINUE
7599       IF ((IOULEV(1).GT.0).AND.(IMODE.GT.0))
7600      &    WRITE(LOUT,*) 'rejected 1 in CH2RES',IMODE
7601       IREJ = 1
7602       IRRES(2) = IRRES(2)+1
7603       RETURN
7604       END
7605
7606 *$ CREATE DT_RJSEAC.FOR
7607 *COPY DT_RJSEAC
7608 *
7609 *===rjseac=============================================================*
7610 *
7611       SUBROUTINE DT_RJSEAC(MOP1,MOP2,MOT1,MOT2,IREJ)
7612
7613 ************************************************************************
7614 * ReJection of SEA-sea Chains.                                         *
7615 *         MOP1/2       entries of projectile sea-partons in DTEVT1     *
7616 *         MOT1/2       entries of projectile sea-partons in DTEVT1     *
7617 * This version dated 16.01.95 is written by S. Roesler                 *
7618 ************************************************************************
7619
7620       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7621       SAVE
7622
7623       PARAMETER ( LINP = 10 ,
7624      &            LOUT = 6 ,
7625      &            LDAT = 9 )
7626
7627       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
7628
7629 * event history
7630
7631       PARAMETER (NMXHKK=200000)
7632
7633       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7634      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7635      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7636
7637 * extended event history
7638       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7639      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7640      &                IHIST(2,NMXHKK)
7641
7642 * statistics
7643       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7644      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7645      &                ICEVTG(8,0:30)
7646
7647       DIMENSION IDXSEA(2,2),IDXNUC(2),ISTVAL(2)
7648
7649       IREJ = 0
7650
7651 * projectile sea q-aq-pair
7652 *    indices of sea-pair
7653       IDXSEA(1,1) = MOP1
7654       IDXSEA(1,2) = MOP2
7655 *    index of mother-nucleon
7656       IDXNUC(1)   = JMOHKK(1,MOP1)
7657 *    status of valence quarks to be corrected
7658       ISTVAL(1)   = -21
7659
7660 * target sea q-aq-pair
7661 *    indices of sea-pair
7662       IDXSEA(2,1) = MOT1
7663       IDXSEA(2,2) = MOT2
7664 *    index of mother-nucleon
7665       IDXNUC(2)   = JMOHKK(1,MOT1)
7666 *    status of valence quarks to be corrected
7667       ISTVAL(2)   = -22
7668
7669       DO 1 N=1,2
7670          IDONE = 0
7671          DO 2 I=NPOINT(2),NHKK
7672             IF ((ISTHKK(I).EQ.ISTVAL(N)).AND.
7673      &          (JMOHKK(1,I).EQ.IDXNUC(N)))   THEN
7674 * valence parton found
7675 *    inrease 4-momentum by sea 4-momentum
7676                DO 3 K=1,4
7677                   PHKK(K,I) = PHKK(K,I)+PHKK(K,IDXSEA(N,1))+
7678      &                                  PHKK(K,IDXSEA(N,2))
7679     3          CONTINUE
7680                PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
7681      &                              PHKK(2,I)**2-PHKK(3,I)**2))
7682 *    "cancel" sea-pair
7683                DO 4 J=1,2
7684                   ISTHKK(IDXSEA(N,J))   = 100
7685                   IDHKK(IDXSEA(N,J))    = 0
7686                   JMOHKK(1,IDXSEA(N,J)) = 0
7687                   JMOHKK(2,IDXSEA(N,J)) = 0
7688                   JDAHKK(1,IDXSEA(N,J)) = 0
7689                   JDAHKK(2,IDXSEA(N,J)) = 0
7690                   DO 5 K=1,4
7691                      PHKK(K,IDXSEA(N,J)) = ZERO
7692                      VHKK(K,IDXSEA(N,J)) = ZERO
7693                      WHKK(K,IDXSEA(N,J)) = ZERO
7694     5             CONTINUE
7695                   PHKK(5,IDXSEA(N,J)) = ZERO
7696     4          CONTINUE
7697                IDONE = 1
7698             ENDIF
7699     2    CONTINUE
7700          IF (IDONE.NE.1) THEN
7701             WRITE(LOUT,1000) NEVHKK,MOP1,MOP2,MOT1,MOT2
7702  1000       FORMAT(1X,'RJSEAC: event ',I8,': inconsistent event',
7703      &                '-record!',/,1X,'        sea-quark pairs   ',
7704      &                2I5,4X,2I5,'   could not be canceled!')
7705             GOTO 9999
7706          ENDIF
7707     1 CONTINUE
7708       ICRJSS = ICRJSS+1
7709       RETURN
7710
7711  9999 CONTINUE
7712       IREJ = 1
7713       RETURN
7714       END
7715
7716 *$ CREATE DT_VV2SCH.FOR
7717 *COPY DT_VV2SCH
7718 *
7719 *===vv2sch=============================================================*
7720 *
7721       SUBROUTINE DT_VV2SCH
7722
7723 ************************************************************************
7724 * Change Valence-Valence chain systems to Single CHain systems for     *
7725 * hadron-nucleus collisions with meson or antibaryon projectile.       *
7726 * (Reggeon contribution)                                               *
7727 * The single chain system is approximately treated as one chain and a  *
7728 * meson at rest.                                                       *
7729 * This version dated 18.01.95 is written by S. Roesler                 *
7730 ************************************************************************
7731
7732       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7733       SAVE
7734
7735       PARAMETER ( LINP = 10 ,
7736      &            LOUT = 6 ,
7737      &            LDAT = 9 )
7738
7739       PARAMETER (ZERO=0.0D0,TINY7=1.0D-7,TINY3=1.0D-3)
7740
7741       LOGICAL LSTART
7742
7743 * event history
7744
7745       PARAMETER (NMXHKK=200000)
7746
7747       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
7748      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
7749      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
7750
7751 * extended event history
7752       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
7753      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
7754      &                IHIST(2,NMXHKK)
7755
7756 * flags for input different options
7757       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
7758       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
7759      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
7760
7761 * statistics
7762       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
7763      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
7764      &                ICEVTG(8,0:30)
7765
7766       DIMENSION IF(4,2),MO(4),PP1(4),PP2(4),PT1(4),PT2(4),PCH1(4),
7767      &          PCH2(4)
7768
7769       DATA LSTART /.TRUE./
7770
7771       IFSC  = 0
7772       IF (LSTART) THEN
7773          WRITE(LOUT,1000)
7774  1000    FORMAT(/,1X,'VV2SCH:  Reggeon contribution to valance-',
7775      &          'valence chains treated')
7776          LSTART = .FALSE.
7777       ENDIF
7778
7779       NSTOP = NHKK
7780
7781 * get index of first chain
7782       DO 1 I=NPOINT(3),NHKK
7783          IF (IDHKK(I).EQ.88888) THEN
7784             NC = I
7785             GOTO 2
7786          ENDIF
7787     1 CONTINUE
7788
7789     2 CONTINUE
7790       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)
7791      &                        .AND.(NC.LT.NSTOP)) THEN
7792 * get valence-valence chains
7793          IF ((IDCH(NC).EQ.8).AND.(IDCH(NC+3).EQ.8)) THEN
7794 *   get "mother"-hadron indices
7795             MO1   = JMOHKK(1,JMOHKK(1,JMOHKK(1,NC)))
7796             MO2   = JMOHKK(1,JMOHKK(1,JMOHKK(2,NC)))
7797             KPROJ = IDT_ICIHAD(IDHKK(MO1))
7798             KTARG = IDT_ICIHAD(IDHKK(MO2))
7799 *   Lab momentum of projectile hadron
7800             CALL DT_LTNUC(PHKK(3,MO1),PHKK(4,MO1),PPZ,PPE,-3)
7801             PTOT  = SQRT(PHKK(1,MO1)**2+PHKK(2,MO1)**2+
7802      &                                  PHKK(3,MO1)**2)
7803
7804             SICHAP = DT_PHNSCH(KPROJ,KTARG,PTOT)
7805             IF (DT_RNDM(PTOT).LE.SICHAP) THEN
7806                ICVV2S = ICVV2S+1
7807 *   single chain requested
7808 *      get flavors of chain-end partons
7809                MO(1) = JMOHKK(1,NC)
7810                MO(2) = JMOHKK(2,NC)
7811                MO(3) = JMOHKK(1,NC+3)
7812                MO(4) = JMOHKK(2,NC+3)
7813                DO 3 I=1,4
7814                   IF(I,1) = IDT_IPDG2B(IDHKK(MO(I)),1,2)
7815                   IF(I,2) = 0
7816                   IF (ABS(IDHKK(MO(I))).GE.1000)
7817      &               IF(I,2) = IDT_IPDG2B(IDHKK(MO(I)),2,2)
7818     3          CONTINUE
7819 *      which one is the q-aq chain?
7820 *        N1,N1+1 - DTEVT1-entries for q-aq system
7821 *        N2,N2+1 - DTEVT1-entries for the other chain
7822                IF ((IF(1,2).EQ.0).AND.(IF(2,2).EQ.0)) THEN
7823                   K1 = 1
7824                   K2 = 3
7825                   N1 = NC-2
7826                   N2 = NC+1
7827                ELSEIF ((IF(3,2).EQ.0).AND.(IF(4,2).EQ.0)) THEN
7828                   K1 = 3
7829                   K2 = 1
7830                   N1 = NC+1
7831                   N2 = NC-2
7832                ELSE
7833                   GOTO 10
7834                ENDIF
7835                DO 4 K=1,4
7836                   PP1(K) = PHKK(K,N1)
7837                   PT1(K) = PHKK(K,N1+1)
7838                   PP2(K) = PHKK(K,N2)
7839                   PT2(K) = PHKK(K,N2+1)
7840     4          CONTINUE
7841                AMCH1 = PHKK(5,N1+2)
7842                AMCH2 = PHKK(5,N2+2)
7843 *      get meson-identity corresponding to flavors of q-aq chain
7844                ITMP   = IRESRJ
7845                IRESRJ = 0
7846                CALL DT_CH2RES(IF(K1,1),IF(K1+1,1),0,0,IDR1,IDXR1,
7847      &                     ZERO,AMCH1N,1,IDUM)
7848                IRESRJ = ITMP
7849 *      change kinematics of chains
7850                CALL DT_CHKINE(PP1,IDHKK(N1),  PP2,IDHKK(N2),
7851      &                     PT1,IDHKK(N1+1),PT2,IDHKK(N2+1),
7852      &                     AMCH1,AMCH1N,AMCH2,IREJ1)
7853                IF (IREJ1.NE.0) GOTO 10
7854 *      check second chain for resonance
7855                IDCHAI = 2
7856                IF ((IF(K2,2).NE.0).AND.(IF(K2+1,2).NE.0)) IDCHAI = 3
7857                CALL DT_CH2RES(IF(K2,1),IF(K2,2),IF(K2+1,1),IF(K2+1,2),
7858      &                     IDR2,IDXR2,AMCH2,AMCH2N,IDCHAI,IREJ1)
7859                IF (IREJ1.NE.0) GOTO 10
7860                IF (IDR2.NE.0) IDR2 = 100*IDR2
7861 *      add partons and chains to DTEVT1
7862                DO 5 K=1,4
7863                   PCH1(K) = PP1(K)+PT1(K)
7864                   PCH2(K) = PP2(K)+PT2(K)
7865     5          CONTINUE
7866                CALL DT_EVTPUT(ISTHKK(N1),IDHKK(N1),N1,0,PP1(1),PP1(2),
7867      &                                             PP1(3),PP1(4),0,0,0)
7868                CALL DT_EVTPUT(ISTHKK(N1+1),IDHKK(N1+1),N1+1,0,PT1(1),
7869      &                                      PT1(2),PT1(3),PT1(4),0,0,0)
7870                KCH = ISTHKK(N1+2)+100
7871                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH1(1),PCH1(2),PCH1(3),
7872      &                     PCH1(4),IDR1,IDXR1,IDCH(N1+2))
7873                IDHKK(N1+2) = 22222
7874                CALL DT_EVTPUT(ISTHKK(N2),IDHKK(N2),N2,0,PP2(1),PP2(2),
7875      &                                             PP2(3),PP2(4),0,0,0)
7876                CALL DT_EVTPUT(ISTHKK(N2+1),IDHKK(N2+1),N2+1,0,PT2(1),
7877      &                                      PT2(2),PT2(3),PT2(4),0,0,0)
7878                KCH = ISTHKK(N2+2)+100
7879                CALL DT_EVTPUT(KCH,88888,-2,-1,PCH2(1),PCH2(2),PCH2(3),
7880      &                     PCH2(4),IDR2,IDXR2,IDCH(N2+2))
7881                IDHKK(N2+2) = 22222
7882             ENDIF
7883          ENDIF
7884       ELSE
7885          GOTO 11
7886       ENDIF
7887    10 CONTINUE
7888       NC = NC+6
7889       GOTO 2
7890
7891    11 CONTINUE
7892
7893       RETURN
7894       END
7895
7896 *$ CREATE DT_PHNSCH.FOR
7897 *COPY DT_PHNSCH
7898 *
7899 *=== phnsch ===========================================================*
7900 *
7901       DOUBLE PRECISION FUNCTION DT_PHNSCH( KP, KTARG, PLAB )
7902
7903 *----------------------------------------------------------------------*
7904 *                                                                      *
7905 *     Probability for Hadron Nucleon Single CHain interactions:        *
7906 *                                                                      *
7907 *     Created on 30 december 1993  by    Alfredo Ferrari & Paola Sala  *
7908 *                                                   Infn - Milan       *
7909 *                                                                      *
7910 *     Last change on 04-jan-94     by    Alfredo Ferrari               *
7911 *                                                                      *
7912 *             modified by J.R.for use in DTUNUC  6.1.94                *
7913 *                                                                      *
7914 *     Input variables:                                                 *
7915 *                      Kp = hadron projectile index (Part numbering    *
7916 *                           scheme)                                    *
7917 *                   Ktarg = target nucleon index (1=proton, 8=neutron) *
7918 *                    Plab = projectile laboratory momentum (GeV/c)     *
7919 *     Output variable:                                                 *
7920 *                  Phnsch = probability per single chain (particle     *
7921 *                           exchange) interactions                     *
7922 *                                                                      *
7923 *----------------------------------------------------------------------*
7924
7925       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
7926       SAVE
7927
7928       PARAMETER ( LUNOUT = 6  )
7929       PARAMETER ( LUNERR = 6  )
7930       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
7931       PARAMETER ( ZERZER = 0.D+00 )
7932       PARAMETER ( ONEONE = 1.D+00 )
7933       PARAMETER ( TWOTWO = 2.D+00 )
7934       PARAMETER ( FIVFIV = 5.D+00 )
7935       PARAMETER ( HLFHLF = 0.5D+00 )
7936
7937       PARAMETER ( NALLWP = 39   )
7938       PARAMETER ( IDMAXP = 210  )
7939
7940       DIMENSION ICHRGE(39),AM(39)
7941
7942 * particle properties (BAMJET index convention)
7943       CHARACTER*8  ANAME
7944       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
7945      &                IICH(210),IIBAR(210),K1(210),K2(210)
7946
7947       DIMENSION KPTOIP(210)
7948
7949 * auxiliary common for reggeon exchange (DTUNUC 1.x)
7950       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
7951      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
7952      &                IQTCHR(-6:6),MQUARK(3,39)
7953
7954       DIMENSION SGTCOE (5,33), IHLP (NALLWP)
7955       DIMENSION SGTCO1(5,10),SGTCO2(5,8),SGTCO3(5,15)
7956       EQUIVALENCE (SGTCO1(1,1),SGTCOE(1,1))
7957       EQUIVALENCE (SGTCO2(1,1),SGTCOE(1,11))
7958       EQUIVALENCE (SGTCO3(1,1),SGTCOE(1,19))
7959
7960 * Conversion from part to paprop numbering
7961       DATA KPTOIP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
7962      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 66*0,
7963      & 34, 36, 31, 32, 33, 35, 37, 5*0, 38, 5*0, 39, 19*0, 27, 28, 74*0/
7964
7965 *  1=baryon, 2=pion, 3=kaon, 4=antibaryon:
7966       DATA IHLP/1,4,5*0,1,4,2*0,3,2*2,2*3,1,4,3,3*1,2,
7967      &    2*3, 2, 4*0, 3*4, 1, 4, 1, 4, 1, 4 /
7968 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=1,10 ) /
7969       DATA  SGTCO1  /
7970 * 1st reaction: gamma p total
7971      &0.147 D+00, ZERZER  , ZERZER   , 0.0022D+00, -0.0170D+00,
7972 * 2nd reaction: gamma d total
7973      &0.300 D+00, ZERZER  , ZERZER   , 0.0095D+00, -0.057 D+00,
7974 * 3rd reaction: pi+ p total
7975      &16.4  D+00, 19.3D+00, -0.42D+00, 0.19  D+00, ZERZER     ,
7976 * 4th reaction: pi- p total
7977      &33.0  D+00, 14.0D+00, -1.36D+00, 0.456 D+00, -4.03  D+00,
7978 * 5th reaction: pi+/- d total
7979      &56.8  D+00, 42.2D+00, -1.45D+00, 0.65  D+00, -5.39  D+00,
7980 * 6th reaction: K+ p total
7981      &18.1  D+00, ZERZER  , ZERZER   , 0.26  D+00, -1.0   D+00,
7982 * 7th reaction: K+ n total
7983      &18.7  D+00, ZERZER  , ZERZER   , 0.21  D+00, -0.89  D+00,
7984 * 8th reaction: K+ d total
7985      &34.2  D+00, 7.9 D+00, -2.1 D+00, 0.346 D+00, -0.99  D+00,
7986 * 9th reaction: K- p total
7987      &32.1  D+00, ZERZER  , ZERZER   , 0.66  D+00, -5.6   D+00,
7988 * 10th reaction: K- n total
7989      &25.2  D+00, ZERZER  , ZERZER   , 0.38  D+00, -2.9   D+00/
7990 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=11,18 ) /
7991       DATA  SGTCO2  /
7992 * 11th reaction: K- d total
7993      &57.6  D+00, ZERZER  , ZERZER   , 1.17  D+00, -9.5   D+00,
7994 * 12th reaction: p p total
7995      &48.0  D+00, ZERZER  , ZERZER   , 0.522 D+00, -4.51  D+00,
7996 * 13th reaction: p n total
7997      &47.30 D+00, ZERZER  , ZERZER   , 0.513 D+00, -4.27  D+00,
7998 * 14th reaction: p d total
7999      &91.3  D+00, ZERZER  , ZERZER   , 1.05  D+00, -8.8   D+00,
8000 * 15th reaction: pbar p total
8001      &38.4  D+00, 77.6D+00, -0.64D+00, 0.26  D+00, -1.2   D+00,
8002 * 16th reaction: pbar n total
8003      &ZERZER    ,133.6D+00, -0.70D+00, -1.22 D+00, 13.7   D+00,
8004 * 17th reaction: pbar d total
8005      &112.  D+00, 125.D+00, -1.08D+00, 1.14  D+00, -12.4  D+00,
8006 * 18th reaction: Lamda p total
8007      &30.4  D+00, ZERZER  , ZERZER   , ZERZER    , 1.6    D+00/
8008 C     DATA ( ( SGTCOE (J,I), J=1,5 ), I=19,33 ) /
8009       DATA SGTCO3  /
8010 * 19th reaction: pi+ p elastic
8011      &ZERZER    , 11.4D+00, -0.4 D+00, 0.079 D+00, ZERZER     ,
8012 * 20th reaction: pi- p elastic
8013      &1.76  D+00, 11.2D+00, -0.64D+00, 0.043 D+00, ZERZER     ,
8014 * 21st reaction: K+ p elastic
8015      &5.0   D+00, 8.1 D+00, -1.8 D+00, 0.16  D+00, -1.3   D+00,
8016 * 22nd reaction: K- p elastic
8017      &7.3   D+00, ZERZER  , ZERZER   , 0.29  D+00, -2.40  D+00,
8018 * 23rd reaction: p p elastic
8019      &11.9  D+00, 26.9D+00, -1.21D+00, 0.169 D+00, -1.85  D+00,
8020 * 24th reaction: p d elastic
8021      &16.1  D+00, ZERZER  , ZERZER   , 0.32  D+00, -3.4   D+00,
8022 * 25th reaction: pbar p elastic
8023      &10.2  D+00, 52.7D+00, -1.16D+00, 0.125 D+00, -1.28  D+00,
8024 * 26th reaction: pbar p elastic bis
8025      &10.6  D+00, 53.1D+00, -1.19D+00, 0.136 D+00, -1.41  D+00,
8026 * 27th reaction: pbar n elastic
8027      &36.5  D+00, ZERZER  , ZERZER   , ZERZER    , -11.9  D+00,
8028 * 28th reaction: Lamda p elastic
8029      &12.3  D+00, ZERZER  , ZERZER   , ZERZER    , -2.4   D+00,
8030 * 29th reaction: K- p ela bis
8031      &7.24  D+00, 46.0D+00, -4.71D+00, 0.279 D+00, -2.35  D+00,
8032 * 30th reaction: pi- p cx
8033      &ZERZER    ,0.912D+00, -1.22D+00, ZERZER    , ZERZER     ,
8034 * 31st reaction: K- p cx
8035      &ZERZER    , 3.39D+00, -1.75D+00, ZERZER    , ZERZER     ,
8036 * 32nd reaction: K+ n cx
8037      &ZERZER    , 7.18D+00, -2.01D+00, ZERZER    , ZERZER     ,
8038 * 33rd reaction: pbar p cx
8039      &ZERZER    , 18.8D+00, -2.01D+00, ZERZER    , ZERZER     /
8040 *
8041 *  +-------------------------------------------------------------------*
8042          ICHRGE(KTARG)=IICH(KTARG)
8043          AM    (KTARG)=AAM (KTARG)
8044 *  |  Check for pi0 (d-dbar)
8045       IF ( KP .NE. 26 ) THEN
8046          IP  = KPTOIP (KP)
8047          IF(IP.EQ.0)IP=1
8048          ICHRGE(IP)=IICH(KP)
8049          AM    (IP)=AAM (KP)
8050 *  |
8051 *  +-------------------------------------------------------------------*
8052 *  |
8053       ELSE
8054          IP = 23
8055          ICHRGE(IP)=0
8056       END IF
8057 *  |
8058 *  +-------------------------------------------------------------------*
8059 *  +-------------------------------------------------------------------*
8060 *  |  No such interactions for baryon-baryon
8061       IF ( IIBAR (KP) .GT. 0 ) THEN
8062          DT_PHNSCH = ZERZER
8063          RETURN
8064 *  |
8065 *  +-------------------------------------------------------------------*
8066 *  |  No "annihilation" diagram possible for K+ p/n
8067       ELSE IF ( IP .EQ. 15 ) THEN
8068          DT_PHNSCH = ZERZER
8069          RETURN
8070 *  |
8071 *  +-------------------------------------------------------------------*
8072 *  |  No "annihilation" diagram possible for K0 p/n
8073       ELSE IF ( IP .EQ. 24 ) THEN
8074          DT_PHNSCH = ZERZER
8075          RETURN
8076 *  |
8077 *  +-------------------------------------------------------------------*
8078 *  |  No "annihilation" diagram possible for Omebar p/n
8079       ELSE IF ( IP .GE. 38 ) THEN
8080          DT_PHNSCH = ZERZER
8081          RETURN
8082       END IF
8083 *  |
8084 *  +-------------------------------------------------------------------*
8085 *  +-------------------------------------------------------------------*
8086 *  |  If the momentum is larger than 50 GeV/c, compute the single
8087 *  |  chain probability at 50 GeV/c and extrapolate to the present
8088 *  |  momentum according to 1/sqrt(s)
8089 *  |  sigma = sigma_sch (50) * sqrt (s(50)/s) + sigma_dch
8090 *  |  P_sch (50) = sigma_sch (50) / ( sigma_dch + sigma_sch (50) )
8091 *  |  sigma_dch / sigma_sch (50) = 1 / P_sch (50) - 1
8092 *  |  sigma_dch / sigma_sch = 1 / P_sch - 1 = ( 1 / P_sch (50) - 1 )
8093 *  |                        x sqrt(s/s(50))
8094 *  |  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8095       IF ( PLAB .GT. 50.D+00 ) THEN
8096          PLA    = 50.D+00
8097          AMPSQ  = AM (IP)**2
8098          AMTSQ  = AM (KTARG)**2
8099          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
8100          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8101          EPROJ  = SQRT ( PLA**2 + AMPSQ )
8102          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8103          UMORAT = SQRT ( UMOSQ / UMO50 )
8104 *  |
8105 *  +-------------------------------------------------------------------*
8106 *  |  P < 3 GeV/c
8107       ELSE IF ( PLAB .LT. 3.D+00 ) THEN
8108          PLA    = 3.D+00
8109          AMPSQ  = AM (IP)**2
8110          AMTSQ  = AM (KTARG)**2
8111          EPROJ  = SQRT ( PLAB**2 + AMPSQ )
8112          UMOSQ  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8113          EPROJ  = SQRT ( PLA**2 + AMPSQ )
8114          UMO50  = AMPSQ + AMTSQ + TWOTWO * AM (KTARG) * EPROJ
8115          UMORAT = SQRT ( UMOSQ / UMO50 )
8116 *  |
8117 *  +-------------------------------------------------------------------*
8118 *  |  P < 50 GeV/c
8119       ELSE
8120          PLA    = PLAB
8121          UMORAT = ONEONE
8122       END IF
8123 *  |
8124 *  +-------------------------------------------------------------------*
8125       ALGPLA = LOG (PLA)
8126 *  +-------------------------------------------------------------------*
8127 *  |  Pions:
8128       IF ( IHLP (IP) .EQ. 2 ) THEN
8129          ACOF = SGTCOE (1,3)
8130          BCOF = SGTCOE (2,3)
8131          ENNE = SGTCOE (3,3)
8132          CCOF = SGTCOE (4,3)
8133          DCOF = SGTCOE (5,3)
8134 *  |  Compute the pi+ p total cross section:
8135          SPPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8136      &          + DCOF * ALGPLA
8137          ACOF = SGTCOE (1,19)
8138          BCOF = SGTCOE (2,19)
8139          ENNE = SGTCOE (3,19)
8140          CCOF = SGTCOE (4,19)
8141          DCOF = SGTCOE (5,19)
8142 *  |  Compute the pi+ p elastic cross section:
8143          SPPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8144      &          + DCOF * ALGPLA
8145 *  |  Compute the pi+ p inelastic cross section:
8146          SPPPIN = SPPPTT - SPPPEL
8147          ACOF = SGTCOE (1,4)
8148          BCOF = SGTCOE (2,4)
8149          ENNE = SGTCOE (3,4)
8150          CCOF = SGTCOE (4,4)
8151          DCOF = SGTCOE (5,4)
8152 *  |  Compute the pi- p total cross section:
8153          SPMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8154      &          + DCOF * ALGPLA
8155          ACOF = SGTCOE (1,20)
8156          BCOF = SGTCOE (2,20)
8157          ENNE = SGTCOE (3,20)
8158          CCOF = SGTCOE (4,20)
8159          DCOF = SGTCOE (5,20)
8160 *  |  Compute the pi- p elastic cross section:
8161          SPMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8162      &          + DCOF * ALGPLA
8163 *  |  Compute the pi- p inelastic cross section:
8164          SPMPIN = SPMPTT - SPMPEL
8165          SIGDIA = SPMPIN - SPPPIN
8166 *  |  +----------------------------------------------------------------*
8167 *  |  |  Charged pions: besides isospin consideration it is supposed
8168 *  |  |                 that (pi+ n)el is almost equal to (pi- p)el
8169 *  |  |                 and  (pi+ p)el "    "     "    "  (pi- n)el
8170 *  |  |                 and all are almost equal among each others
8171 *  |  |                 (reasonable above 5 GeV/c)
8172          IF ( ICHRGE (IP) .NE. 0 ) THEN
8173             KHELP = KTARG / 8
8174             JREAC = 3 + IP - 13 + ICHRGE (IP) * KHELP
8175             ACOF = SGTCOE (1,JREAC)
8176             BCOF = SGTCOE (2,JREAC)
8177             ENNE = SGTCOE (3,JREAC)
8178             CCOF = SGTCOE (4,JREAC)
8179             DCOF = SGTCOE (5,JREAC)
8180 *  |  |  Compute the total cross section:
8181             SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8182      &             + DCOF * ALGPLA
8183             JREAC = 19 + IP - 13 + ICHRGE (IP) * KHELP
8184             ACOF = SGTCOE (1,JREAC)
8185             BCOF = SGTCOE (2,JREAC)
8186             ENNE = SGTCOE (3,JREAC)
8187             CCOF = SGTCOE (4,JREAC)
8188             DCOF = SGTCOE (5,JREAC)
8189 *  |  |  Compute the elastic cross section:
8190             SHNCEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8191      &             + DCOF * ALGPLA
8192 *  |  |  Compute the inelastic cross section:
8193             SHNCIN = SHNCTT - SHNCEL
8194 *  |  |  Number of diagrams:
8195             NDIAGR = 1 + IP - 13 + ICHRGE (IP) * KHELP
8196 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8197             IQFSC1 = 1 + IP - 13
8198             IQFSC2 = 0
8199             IQBSC1 = 1 + KHELP
8200             IQBSC2 = 1 + IP - 13
8201 *  |  |
8202 *  |  +----------------------------------------------------------------*
8203 *  |  |  pi0: besides isospin consideration it is supposed that the
8204 *  |  |       elastic cross section is not very different from
8205 *  |  |       pi+ p and/or pi- p (reasonable above 5 GeV/c)
8206          ELSE
8207             KHELP  = KTARG / 8
8208             K2HLP  = ( KP - 23 ) / 3
8209 *  |  |  Number of diagrams:
8210 *  |  |  For u ubar (k2hlp=0):
8211 *           NDIAGR = 2 - KHELP
8212 *  |  |  For d dbar (k2hlp=1):
8213 *           NDIAGR = 2 + KHELP - K2HLP
8214             NDIAGR = 2 + KHELP * ( 2 * K2HLP - 1 ) - K2HLP
8215             SHNCIN = HLFHLF * ( SPPPIN + SPMPIN )
8216 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8217             IQFSC1 = 1 + K2HLP
8218             IQFSC2 = 0
8219             IQBSC1 = 1 + KHELP
8220             IQBSC2 = 2 - K2HLP
8221          END IF
8222 *  |  |
8223 *  |  +----------------------------------------------------------------*
8224 *  |                                                   end pi's
8225 *  +-------------------------------------------------------------------*
8226 *  |  Kaons:
8227       ELSE IF ( IHLP (IP) .EQ. 3 ) THEN
8228          ACOF = SGTCOE (1,6)
8229          BCOF = SGTCOE (2,6)
8230          ENNE = SGTCOE (3,6)
8231          CCOF = SGTCOE (4,6)
8232          DCOF = SGTCOE (5,6)
8233 *  |  Compute the K+ p total cross section:
8234          SKPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8235      &          + DCOF * ALGPLA
8236          ACOF = SGTCOE (1,21)
8237          BCOF = SGTCOE (2,21)
8238          ENNE = SGTCOE (3,21)
8239          CCOF = SGTCOE (4,21)
8240          DCOF = SGTCOE (5,21)
8241 *  |  Compute the K+ p elastic cross section:
8242          SKPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8243      &          + DCOF * ALGPLA
8244 *  |  Compute the K+ p inelastic cross section:
8245          SKPPIN = SKPPTT - SKPPEL
8246          ACOF = SGTCOE (1,9)
8247          BCOF = SGTCOE (2,9)
8248          ENNE = SGTCOE (3,9)
8249          CCOF = SGTCOE (4,9)
8250          DCOF = SGTCOE (5,9)
8251 *  |  Compute the K- p total cross section:
8252          SKMPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8253      &          + DCOF * ALGPLA
8254          ACOF = SGTCOE (1,22)
8255          BCOF = SGTCOE (2,22)
8256          ENNE = SGTCOE (3,22)
8257          CCOF = SGTCOE (4,22)
8258          DCOF = SGTCOE (5,22)
8259 *  |  Compute the K- p elastic cross section:
8260          SKMPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8261      &          + DCOF * ALGPLA
8262 *  |  Compute the K- p inelastic cross section:
8263          SKMPIN = SKMPTT - SKMPEL
8264          SIGDIA = HLFHLF * ( SKMPIN - SKPPIN )
8265 *  |  +----------------------------------------------------------------*
8266 *  |  |  Charged Kaons: actually only K-
8267          IF ( ICHRGE (IP) .NE. 0 ) THEN
8268             KHELP = KTARG / 8
8269 *  |  |  +-------------------------------------------------------------*
8270 *  |  |  |  Proton target:
8271             IF ( KHELP .EQ. 0 ) THEN
8272                SHNCIN = SKMPIN
8273 *  |  |  |  Number of diagrams:
8274                NDIAGR = 2
8275 *  |  |  |
8276 *  |  |  +-------------------------------------------------------------*
8277 *  |  |  |  Neutron target: besides isospin consideration it is supposed
8278 *  |  |  |              that (K- n)el is almost equal to (K- p)el
8279 *  |  |  |              (reasonable above 5 GeV/c)
8280             ELSE
8281                ACOF = SGTCOE (1,10)
8282                BCOF = SGTCOE (2,10)
8283                ENNE = SGTCOE (3,10)
8284                CCOF = SGTCOE (4,10)
8285                DCOF = SGTCOE (5,10)
8286 *  |  |  |  Compute the total cross section:
8287                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8288      &                + DCOF * ALGPLA
8289 *  |  |  |  Compute the elastic cross section:
8290                SHNCEL = SKMPEL
8291 *  |  |  |  Compute the inelastic cross section:
8292                SHNCIN = SHNCTT - SHNCEL
8293 *  |  |  |  Number of diagrams:
8294                NDIAGR = 1
8295             END IF
8296 *  |  |  |
8297 *  |  |  +-------------------------------------------------------------*
8298 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8299             IQFSC1 = 3
8300             IQFSC2 = 0
8301             IQBSC1 = 1 + KHELP
8302             IQBSC2 = 2
8303 *  |  |
8304 *  |  +----------------------------------------------------------------*
8305 *  |  |  K0's: (actually only K0bar)
8306          ELSE
8307             KHELP  = KTARG / 8
8308 *  |  |  +-------------------------------------------------------------*
8309 *  |  |  |  Proton target: (K0bar p)in supposed to be given by
8310 *  |  |  |                 (K- p)in - Sig_diagr
8311             IF ( KHELP .EQ. 0 ) THEN
8312                SHNCIN = SKMPIN - SIGDIA
8313 *  |  |  |  Number of diagrams:
8314                NDIAGR = 1
8315 *  |  |  |
8316 *  |  |  +-------------------------------------------------------------*
8317 *  |  |  |  Neutron target: (K0bar n)in supposed to be given by
8318 *  |  |  |                 (K- n)in + Sig_diagr
8319 *  |  |  |              besides isospin consideration it is supposed
8320 *  |  |  |              that (K- n)el is almost equal to (K- p)el
8321 *  |  |  |              (reasonable above 5 GeV/c)
8322             ELSE
8323                ACOF = SGTCOE (1,10)
8324                BCOF = SGTCOE (2,10)
8325                ENNE = SGTCOE (3,10)
8326                CCOF = SGTCOE (4,10)
8327                DCOF = SGTCOE (5,10)
8328 *  |  |  |  Compute the total cross section:
8329                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8330      &                + DCOF * ALGPLA
8331 *  |  |  |  Compute the elastic cross section:
8332                SHNCEL = SKMPEL
8333 *  |  |  |  Compute the inelastic cross section:
8334                SHNCIN = SHNCTT - SHNCEL + SIGDIA
8335 *  |  |  |  Number of diagrams:
8336                NDIAGR = 2
8337             END IF
8338 *  |  |  |
8339 *  |  |  +-------------------------------------------------------------*
8340 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8341             IQFSC1 = 3
8342             IQFSC2 = 0
8343             IQBSC1 = 1
8344             IQBSC2 = 1 + KHELP
8345          END IF
8346 *  |  |
8347 *  |  +----------------------------------------------------------------*
8348 *  |                                                   end Kaon's
8349 *  +-------------------------------------------------------------------*
8350 *  |  Antinucleons:
8351       ELSE IF ( IHLP (IP) .EQ. 4 .AND. IP .LE. 9 ) THEN
8352 *  |  For momenta between 3 and 5 GeV/c the use of tabulated data
8353 *  |  should be implemented!
8354          ACOF = SGTCOE (1,15)
8355          BCOF = SGTCOE (2,15)
8356          ENNE = SGTCOE (3,15)
8357          CCOF = SGTCOE (4,15)
8358          DCOF = SGTCOE (5,15)
8359 *  |  Compute the pbar p total cross section:
8360          SAPPTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8361      &          + DCOF * ALGPLA
8362          IF ( PLA .LT. FIVFIV ) THEN
8363             JREAC = 26
8364          ELSE
8365             JREAC = 25
8366          END IF
8367          ACOF = SGTCOE (1,JREAC)
8368          BCOF = SGTCOE (2,JREAC)
8369          ENNE = SGTCOE (3,JREAC)
8370          CCOF = SGTCOE (4,JREAC)
8371          DCOF = SGTCOE (5,JREAC)
8372 *  |  Compute the pbar p elastic cross section:
8373          SAPPEL = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8374      &          + DCOF * ALGPLA
8375 *  |  Compute the pbar p inelastic cross section:
8376          SAPPIN = SAPPTT - SAPPEL
8377          ACOF = SGTCOE (1,12)
8378          BCOF = SGTCOE (2,12)
8379          ENNE = SGTCOE (3,12)
8380          CCOF = SGTCOE (4,12)
8381          DCOF = SGTCOE (5,12)
8382 *  |  Compute the p p total cross section:
8383          SPPTOT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8384      &          + DCOF * ALGPLA
8385          ACOF = SGTCOE (1,23)
8386          BCOF = SGTCOE (2,23)
8387          ENNE = SGTCOE (3,23)
8388          CCOF = SGTCOE (4,23)
8389          DCOF = SGTCOE (5,23)
8390 *  |  Compute the p p elastic cross section:
8391          SPPELA = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8392      &          + DCOF * ALGPLA
8393 *  |  Compute the K- p inelastic cross section:
8394          SPPINE = SPPTOT - SPPELA
8395          SIGDIA = ( SAPPIN - SPPINE ) / FIVFIV
8396          KHELP  = KTARG / 8
8397 *  |  +----------------------------------------------------------------*
8398 *  |  |  Pbar:
8399          IF ( ICHRGE (IP) .NE. 0 ) THEN
8400             NDIAGR = 5 - KHELP
8401 *  |  |  +-------------------------------------------------------------*
8402 *  |  |  |  Proton target:
8403             IF ( KHELP .EQ. 0 ) THEN
8404 *  |  |  |  Number of diagrams:
8405                SHNCIN = SAPPIN
8406                PUUBAR = 0.8D+00
8407 *  |  |  |
8408 *  |  |  +-------------------------------------------------------------*
8409 *  |  |  |  Neutron target: it is supposed that (ap n)el is almost equal
8410 *  |  |  |                  to (ap p)el (reasonable above 5 GeV/c)
8411             ELSE
8412                ACOF = SGTCOE (1,16)
8413                BCOF = SGTCOE (2,16)
8414                ENNE = SGTCOE (3,16)
8415                CCOF = SGTCOE (4,16)
8416                DCOF = SGTCOE (5,16)
8417 *  |  |  |  Compute the total cross section:
8418                SHNCTT = ACOF + BCOF * PLA**ENNE + CCOF * ALGPLA**2
8419      &                + DCOF * ALGPLA
8420 *  |  |  |  Compute the elastic cross section:
8421                SHNCEL = SAPPEL
8422 *  |  |  |  Compute the inelastic cross section:
8423                SHNCIN = SHNCTT - SHNCEL
8424                PUUBAR = HLFHLF
8425             END IF
8426 *  |  |  |
8427 *  |  |  +-------------------------------------------------------------*
8428 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8429 *  |  |  there are different possibilities, make a random choiche:
8430             IQFSC1 = -1
8431             RNCHEN = DT_RNDM(PUUBAR)
8432             IF ( RNCHEN .LT. PUUBAR ) THEN
8433                IQFSC2 = -2
8434             ELSE
8435                IQFSC2 = -1
8436             END IF
8437             IQBSC1 = -IQFSC1 + KHELP
8438             IQBSC2 = -IQFSC2
8439 *  |  |
8440 *  |  +----------------------------------------------------------------*
8441 *  |  |  nbar:
8442          ELSE
8443             NDIAGR = 4 + KHELP
8444 *  |  |  +-------------------------------------------------------------*
8445 *  |  |  |  Proton target: (nbar p)in supposed to be given by
8446 *  |  |  |                 (pbar p)in - Sig_diagr
8447             IF ( KHELP .EQ. 0 ) THEN
8448                SHNCIN = SAPPIN - SIGDIA
8449                PDDBAR = HLFHLF
8450 *  |  |  |
8451 *  |  |  +-------------------------------------------------------------*
8452 *  |  |  |  Neutron target: (nbar n)el is supposed to be equal to
8453 *  |  |  |                  (pbar p)el (reasonable above 5 GeV/c)
8454             ELSE
8455 *  |  |  |  Compute the total cross section:
8456                SHNCTT = SAPPTT
8457 *  |  |  |  Compute the elastic cross section:
8458                SHNCEL = SAPPEL
8459 *  |  |  |  Compute the inelastic cross section:
8460                SHNCIN = SHNCTT - SHNCEL
8461                PDDBAR = 0.8D+00
8462             END IF
8463 *  |  |  |
8464 *  |  |  +-------------------------------------------------------------*
8465 *  |  |  Now compute the chain end (anti)quark-(anti)diquark
8466 *  |  |  there are different possibilities, make a random choiche:
8467             IQFSC1 = -2
8468             RNCHEN = DT_RNDM(RNCHEN)
8469             IF ( RNCHEN .LT. PDDBAR ) THEN
8470                IQFSC2 = -1
8471             ELSE
8472                IQFSC2 = -2
8473             END IF
8474             IQBSC1 = -IQFSC1 + KHELP - 1
8475             IQBSC2 = -IQFSC2
8476          END IF
8477 *  |  |
8478 *  |  +----------------------------------------------------------------*
8479 *  |
8480 *  +-------------------------------------------------------------------*
8481 *  |  Others: not yet implemented
8482       ELSE
8483          SIGDIA = ZERZER
8484          SHNCIN = ONEONE
8485          NDIAGR = 0
8486          DT_PHNSCH = ZERZER
8487          RETURN
8488       END IF
8489 *  |                                                   end others
8490 *  +-------------------------------------------------------------------*
8491       DT_PHNSCH = NDIAGR * SIGDIA / SHNCIN
8492       IQECHC = IQECHR (IQFSC1) + IQECHR (IQFSC2) + IQECHR (IQBSC1)
8493      &       + IQECHR (IQBSC2)
8494       IQBCHC = IQBCHR (IQFSC1) + IQBCHR (IQFSC2) + IQBCHR (IQBSC1)
8495      &       + IQBCHR (IQBSC2)
8496       IQECHC = IQECHC / 3
8497       IQBCHC = IQBCHC / 3
8498       IQSCHC = IQSCHR (IQFSC1) + IQSCHR (IQFSC2) + IQSCHR (IQBSC1)
8499      &       + IQSCHR (IQBSC2)
8500       IQSPRO = IQSCHR (MQUARK(1,IP)) + IQSCHR (MQUARK(2,IP))
8501      &       + IQSCHR (MQUARK(3,IP))
8502 *  +-------------------------------------------------------------------*
8503 *  |  Consistency check:
8504       IF ( DT_PHNSCH .LE. ZERZER .OR. DT_PHNSCH .GT. ONEONE ) THEN
8505          WRITE (LUNOUT,*)' *** Phnsch,kp,ktarg,pla',
8506      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8507          WRITE (LUNERR,*)' *** Phnsch,kp,ktarg,pla',
8508      &                         DT_PHNSCH,KP,KTARG,PLA,' ****'
8509          DT_PHNSCH = MAX ( DT_PHNSCH, ZERZER )
8510          DT_PHNSCH = MIN ( DT_PHNSCH, ONEONE )
8511       END IF
8512 *  |
8513 *  +-------------------------------------------------------------------*
8514 *  +-------------------------------------------------------------------*
8515 *  |  Consistency check:
8516       IF ( IQSPRO .NE. IQSCHC .OR. ICHRGE (IP) + ICHRGE (KTARG)
8517      &     .NE. IQECHC .OR. IIBAR (KP) + IIBAR (KTARG) .NE. IQBCHC) THEN
8518          WRITE (LUNOUT,*)
8519      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8520      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8521          WRITE (LUNERR,*)
8522      &' *** Phnsch,iqspro,iqschc,ichrge,iqechc,ibar,iqbchc,ktarg',
8523      &      IQSPRO,IQSCHC,ICHRGE(IP),IQECHC,IIBAR(KP),IQBCHC,KTARG
8524       END IF
8525 *  |
8526 *  +-------------------------------------------------------------------*
8527 *  P_sch = 1 / [ ( 1 / P_sch (50) - 1 ) x sqrt(s/s(50)) + 1 ]
8528       IF ( UMORAT .GT. ONEPLS )
8529      &   DT_PHNSCH = ONEONE / ( ( ONEONE / DT_PHNSCH
8530      &                                 - ONEONE ) * UMORAT + ONEONE )
8531       RETURN
8532 *
8533       ENTRY DT_SCHQUA ( JQFSC1, JQFSC2, JQBSC1, JQBSC2 )
8534       DT_SCHQUA = ONEONE
8535       JQFSC1 = IQFSC1
8536       JQFSC2 = IQFSC2
8537       JQBSC1 = IQBSC1
8538       JQBSC2 = IQBSC2
8539 *=== End of function Phnsch ===========================================*
8540       RETURN
8541       END
8542
8543 *$ CREATE DT_RESPT.FOR
8544 *COPY DT_RESPT
8545 *
8546 *===respt==============================================================*
8547 *
8548       SUBROUTINE DT_RESPT
8549
8550 ************************************************************************
8551 * Check DTEVT1 for two-resonance systems and sample intrinsic p_t.     *
8552 * This version dated 18.01.95 is written by S. Roesler                 *
8553 ************************************************************************
8554
8555       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8556       SAVE
8557
8558       PARAMETER ( LINP = 10 ,
8559      &            LOUT = 6 ,
8560      &            LDAT = 9 )
8561
8562       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
8563
8564 * event history
8565
8566       PARAMETER (NMXHKK=200000)
8567
8568       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8569      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8570      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8571
8572 * extended event history
8573       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8574      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8575      &                IHIST(2,NMXHKK)
8576
8577 * get index of first chain
8578       DO 1 I=NPOINT(3),NHKK
8579          IF (IDHKK(I).EQ.88888) THEN
8580             NC = I
8581             GOTO 2
8582          ENDIF
8583     1 CONTINUE
8584
8585     2 CONTINUE
8586       IF ((IDHKK(NC).EQ.88888).AND.(IDHKK(NC+3).EQ.88888)) THEN
8587 C        WRITE(LOUT,*)NC,NC+3,IDRES(NC),IDRES(NC+3)
8588 * skip VV-,SS- systems
8589          IF ((IDCH(NC  ).NE.1).AND.(IDCH(NC  ).NE.8).AND.
8590      &       (IDCH(NC+3).NE.1).AND.(IDCH(NC+3).NE.8)) THEN
8591 * check if both "chains" are resonances
8592             IF ((IDRES(NC).NE.0).AND.(IDRES(NC+3).NE.0)) THEN
8593                CALL DT_SAPTRE(NC,NC+3)
8594             ENDIF
8595          ENDIF
8596       ELSE
8597          GOTO 3
8598       ENDIF
8599       NC = NC+6
8600       GOTO 2
8601
8602     3 CONTINUE
8603
8604       RETURN
8605       END
8606
8607 *$ CREATE DT_EVTRES.FOR
8608 *COPY DT_EVTRES
8609 *
8610 *===evtres=============================================================*
8611 *
8612       SUBROUTINE DT_EVTRES(IREJ)
8613
8614 ************************************************************************
8615 * This version dated 14.12.94 is written by S. Roesler                 *
8616 ************************************************************************
8617
8618       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8619       SAVE
8620
8621       PARAMETER ( LINP = 10 ,
8622      &            LOUT = 6 ,
8623      &            LDAT = 9 )
8624
8625       PARAMETER (TINY5=1.0D-5,TINY10=1.0D-10)
8626
8627 * event history
8628
8629       PARAMETER (NMXHKK=200000)
8630
8631       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
8632      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
8633      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
8634
8635 * extended event history
8636       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
8637      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
8638      &                IHIST(2,NMXHKK)
8639
8640 * flags for input different options
8641       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8642       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8643      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8644
8645 * particle properties (BAMJET index convention)
8646       CHARACTER*8  ANAME
8647       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
8648      &                IICH(210),IIBAR(210),K1(210),K2(210)
8649
8650       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),IFP(2),IFT(2)
8651
8652       IREJ = 0
8653
8654       DO 1 I=NPOINT(3),NHKK
8655          IF (ABS(IDRES(I)).GE.100) THEN
8656             AMMX = 0.0D0
8657             DO 2 J=NPOINT(3),NHKK
8658                IF (IDHKK(J).EQ.88888) THEN
8659                   IF (PHKK(5,J).GT.AMMX) THEN
8660                      AMMX = PHKK(5,J)
8661                      IMMX = J
8662                   ENDIF
8663                ENDIF
8664     2       CONTINUE
8665             IF (IDRES(IMMX).NE.0) THEN
8666                IF (IOULEV(3).GT.0) THEN
8667                   WRITE(LOUT,'(1X,A)')
8668      &               'EVTRES: no chain for correc. found'
8669 C                 GOTO 6
8670                   GOTO 9999
8671                ELSE
8672                   GOTO 9999
8673                ENDIF
8674             ENDIF
8675             IMO11  = JMOHKK(1,I)
8676             IMO12  = JMOHKK(2,I)
8677             IF (PHKK(3,IMO11).LT.0.0D0) THEN
8678                IMO11 = JMOHKK(2,I)
8679                IMO12 = JMOHKK(1,I)
8680             ENDIF
8681             IMO21  = JMOHKK(1,IMMX)
8682             IMO22  = JMOHKK(2,IMMX)
8683             IF (PHKK(3,IMO21).LT.0.0D0) THEN
8684                IMO21 = JMOHKK(2,IMMX)
8685                IMO22 = JMOHKK(1,IMMX)
8686             ENDIF
8687             AMCH1  = PHKK(5,I)
8688             AMCH1N = AAM(IDXRES(I))
8689
8690             IFPR1 = IDHKK(IMO11)
8691             IFPR2 = IDHKK(IMO21)
8692             IFTA1 = IDHKK(IMO12)
8693             IFTA2 = IDHKK(IMO22)
8694             DO 4 J=1,4
8695                PP1(J) = PHKK(J,IMO11)
8696                PP2(J) = PHKK(J,IMO21)
8697                PT1(J) = PHKK(J,IMO12)
8698                PT2(J) = PHKK(J,IMO22)
8699     4       CONTINUE
8700 * store initial configuration for energy-momentum cons. check
8701             IF (LEMCCK) CALL DT_EMC1(PP1,PP2,PT1,PT2,1,1,IREJ1)
8702 * correct kinematics of second chain
8703             CALL DT_CHKINE(PP1,IFPR1,PP2,IFPR2,PT1,IFTA1,PT2,IFTA2,
8704      &                  AMCH1,AMCH1N,AMCH2,IREJ1)
8705             IF (IREJ1.NE.0) GOTO 9999
8706 * check now this chain for resonance mass
8707             IFP(1) = IDT_IPDG2B(IFPR2,1,2)
8708             IFP(2) = 0
8709             IF (ABS(IFPR2).GE.1000) IFP(2) = IDT_IPDG2B(IFPR2,2,2)
8710             IFT(1) = IDT_IPDG2B(IFTA2,1,2)
8711             IFT(2) = 0
8712             IF (ABS(IFTA2).GE.1000) IFT(2) = IDT_IPDG2B(IFTA2,2,2)
8713             IDCH2 = 2
8714             IF ((IFP(2).EQ.0).AND.(IFT(2).EQ.0)) IDCH2 = 1
8715             IF ((IFP(2).NE.0).AND.(IFT(2).NE.0)) IDCH2 = 3
8716             CALL DT_CH2RES(IFP(1),IFP(2),IFT(1),IFT(2),IDR2,IDXR2,
8717      &                  AMCH2,AMCH2N,IDCH2,IREJ1)
8718             IF ((IREJ1.NE.0).OR.(IDR2.NE.0)) THEN
8719                IF (IOULEV(1).GT.0)
8720      &            WRITE(LOUT,*) ' correction for resonance not poss.'
8721 **sr test
8722 C              GOTO 1
8723 C              GOTO 9999
8724 **
8725             ENDIF
8726 * store final configuration for energy-momentum cons. check
8727             IF (LEMCCK) THEN
8728                CALL DT_EMC1(PP1,PP2,PT1,PT2,-2,1,IREJ1)
8729                CALL DT_EMC1(PP1,PP2,PT1,PT2,3,1,IREJ1)
8730                IF (IREJ1.NE.0) GOTO 9999
8731             ENDIF
8732             DO 5 J=1,4
8733                PHKK(J,IMO11) = PP1(J)
8734                PHKK(J,IMO21) = PP2(J)
8735                PHKK(J,IMO12) = PT1(J)
8736                PHKK(J,IMO22) = PT2(J)
8737     5       CONTINUE
8738 * correct entries of chains
8739             DO 3 K=1,4
8740                PHKK(K,I)    = PHKK(K,IMO11)+PHKK(K,IMO12)
8741                PHKK(K,IMMX) = PHKK(K,IMO21)+PHKK(K,IMO22)
8742     3       CONTINUE
8743             AM1 = PHKK(4,I)**2-PHKK(1,I)**2-PHKK(2,I)**2-PHKK(3,I)**2
8744             AM2 = PHKK(4,IMMX)**2-PHKK(1,IMMX)**2-PHKK(2,IMMX)**2-
8745      &            PHKK(3,IMMX)**2
8746 * ?? the following should now be obsolete
8747 **sr test
8748 C           IF ((AM1.LT.0.0D0).OR.(AM2.LT.1.0D0)) THEN
8749             IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8750 **
8751                WRITE(LOUT,'(1X,A,4G10.3)')
8752      &          'EVTRES: inonsistent mass-corr.',AM1,AM2
8753 C              GOTO 9999
8754                GOTO 1
8755             ENDIF
8756             PHKK(5,I)    = SQRT(AM1)
8757             PHKK(5,IMMX) = SQRT(AM2)
8758             IDRES(I)     = IDRES(I)/100
8759             IF ((ABS(PHKK(5,I)-AMCH1N).GT.TINY5).OR.
8760      &          (ABS(PHKK(5,IMMX)-AMCH2).GT.TINY5)) THEN
8761                WRITE(LOUT,'(1X,A,4G10.3)')
8762      &          'EVTRES: inconsistent chain-masses',
8763      &          PHKK(5,I),AMCH1N,PHKK(5,IMMX),AMCH2
8764                GOTO 9999
8765             ENDIF
8766          ENDIF
8767     1 CONTINUE
8768     6 CONTINUE
8769       RETURN
8770
8771  9999 CONTINUE
8772       IREJ = 1
8773       RETURN
8774       END
8775
8776 *$ CREATE DT_GETSPT.FOR
8777 *COPY DT_GETSPT
8778 *
8779 *===getspt=============================================================*
8780 *
8781       SUBROUTINE DT_GETSPT(PP1I,IFPR1,IFP1,PP2I,IFPR2,IFP2,
8782      &                  PT1I,IFTA1,IFT1,PT2I,IFTA2,IFT2,
8783      &                  AM1,IDCH1,AM2,IDCH2,IDCHAI,IREJ)
8784
8785 ************************************************************************
8786 * This version dated 12.12.94 is written by S. Roesler                 *
8787 ************************************************************************
8788
8789       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
8790       SAVE
8791
8792       PARAMETER ( LINP = 10 ,
8793      &            LOUT = 6 ,
8794      &            LDAT = 9 )
8795
8796       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,ZERO=0.0D0)
8797
8798 * various options for treatment of partons (DTUNUC 1.x)
8799 * (chain recombination, Cronin,..)
8800       LOGICAL LCO2CR,LINTPT
8801       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
8802      &                LCO2CR,LINTPT
8803
8804 * flags for input different options
8805       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
8806       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
8807      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
8808
8809 * flags for diffractive interactions (DTUNUC 1.x)
8810       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
8811
8812       DIMENSION PP1(4),PP1I(4),PP2(4),PP2I(4),PT1(4),PT1I(4),
8813      &          PT2(4),PT2I(4),P1(4),P2(4),
8814      &          IFP1(2),IFP2(2),IFT1(2),IFT2(2),
8815      &          PTOTI(4),PTOTF(4),DIFF(4)
8816
8817       IC   = 0
8818       IREJ = 0
8819 C     B33P = 4.0D0
8820 C     B33T = 4.0D0
8821 C     IF ((IDCHAI.EQ.6).OR.(IDCHAI.EQ.7).OR.(IDCHAI.EQ.8)) B33P = 2.0D0
8822 C     IF ((IDCHAI.EQ.4).OR.(IDCHAI.EQ.5).OR.(IDCHAI.EQ.8)) B33T = 2.0D0
8823       REDU = 1.0D0
8824 C     B33P = 3.5D0
8825 C     B33T = 3.5D0
8826       B33P = 4.0D0
8827       B33T = 4.0D0
8828       IF (IDIFF.NE.0) THEN
8829          B33P = 16.0D0
8830          B33T = 16.0D0
8831       ENDIF
8832
8833       DO 1 I=1,4
8834          PTOTI(I) = PP1I(I)+PP2I(I)+PT1I(I)+PT2I(I)
8835          PP1(I)   = PP1I(I)
8836          PP2(I)   = PP2I(I)
8837          PT1(I)   = PT1I(I)
8838          PT2(I)   = PT2I(I)
8839     1 CONTINUE
8840 * get initial chain masses
8841       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8842      &                               +(PP1(3)+PT1(3))**2)
8843       ECH   = PP1(4)+PT1(4)
8844       AM1   = (ECH+PTOCH)*(ECH-PTOCH)
8845       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
8846      &                               +(PP2(3)+PT2(3))**2)
8847       ECH   = PP2(4)+PT2(4)
8848       AM2   = (ECH+PTOCH)*(ECH-PTOCH)
8849       IF ((AM1.LT.0.0D0).OR.(AM2.LT.0.0D0)) THEN
8850          IF (IOULEV(1).GT.0)
8851      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 1',
8852      &                              AM1,AM2
8853          GOTO 9999
8854       ENDIF
8855       AM1  = SQRT(AM1)
8856       AM2  = SQRT(AM2)
8857       AM1N = ZERO
8858       AM2N = ZERO
8859
8860       MODE = 0
8861 C      IF ((AM1.GE.3.0D0).AND.(AM2.GE.3.0D0)) THEN
8862 C        MODE = 0
8863 C      ELSE
8864 C         MODE = 1
8865 C         IF (AM1.LT.0.6) THEN
8866 C            B33P = 10.0D0
8867 C         ELSEIF ((AM1.GE.1.2).AND.(AM1.LT.3.0D0)) THEN
8868 CC           B33P = 4.0D0
8869 C         ENDIF
8870 C         IF (AM2.LT.0.6) THEN
8871 C            B33T = 10.0D0
8872 C         ELSEIF ((AM2.GE.1.2).AND.(AM2.LT.3.0D0)) THEN
8873 CC           B33T = 4.0D0
8874 C         ENDIF
8875 C      ENDIF
8876
8877 * check chain masses for very low mass chains
8878 C     CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
8879 C    &            AM1,DUM,-IDCH1,IREJ1)
8880 C     CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
8881 C    &            AM2,DUM,-IDCH2,IREJ2)
8882 C     IF ((IREJ1.NE.0).OR.(IREJ2.NE.0)) THEN
8883 C        B33P = 20.0D0
8884 C        B33T = 20.0D0
8885 C     ENDIF
8886
8887       JMSHL = IMSHL
8888
8889     2 CONTINUE
8890       IC = IC+1
8891       IF (MOD(IC,15).EQ.0) B33P  = 2.0D0*B33P
8892       IF (MOD(IC,15).EQ.0) B33T  = 2.0D0*B33T
8893       IF (MOD(IC,18).EQ.0) REDU  = 0.0D0
8894 C     IF (MOD(IC,19).EQ.0) JMSHL = 0
8895       IF (MOD(IC,20).EQ.0) GOTO 7
8896 C        WRITE(LOUT,'(1X,A)') 'GETSPT: rejection '
8897 C        RETURN
8898 C        GOTO 9999
8899 C     ENDIF
8900
8901 * get transverse momentum
8902       IF (LINTPT) THEN
8903          ES   = -2.0D0/(B33P**2)
8904      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8905          HPSP = SQRT(ES*ES+2.0D0*ES*0.94D0)
8906          HPSP = HPSP*REDU
8907          ES   = -2.0D0/(B33T**2)
8908      &          *LOG(ABS(DT_RNDM(AM1)*DT_RNDM(AM2))+TINY10)
8909          HPST = SQRT(ES*ES+2.0D0*ES*0.94D0)
8910          HPST = HPST*REDU
8911       ELSE
8912          HPSP = ZERO
8913          HPST = ZERO
8914       ENDIF
8915       CALL DT_DSFECF(SFE1,CFE1)
8916       CALL DT_DSFECF(SFE2,CFE2)
8917       IF (MODE.EQ.0) THEN
8918          PP1(1) = PP1I(1)+HPSP*CFE1
8919          PP1(2) = PP1I(2)+HPSP*SFE1
8920          PP2(1) = PP2I(1)-HPSP*CFE1
8921          PP2(2) = PP2I(2)-HPSP*SFE1
8922          PT1(1) = PT1I(1)+HPST*CFE2
8923          PT1(2) = PT1I(2)+HPST*SFE2
8924          PT2(1) = PT2I(1)-HPST*CFE2
8925          PT2(2) = PT2I(2)-HPST*SFE2
8926       ELSE
8927          PP1(1) = PP1I(1)+HPSP*CFE1
8928          PP1(2) = PP1I(2)+HPSP*SFE1
8929          PT1(1) = PT1I(1)-HPSP*CFE1
8930          PT1(2) = PT1I(2)-HPSP*SFE1
8931          PP2(1) = PP2I(1)+HPST*CFE2
8932          PP2(2) = PP2I(2)+HPST*SFE2
8933          PT2(1) = PT2I(1)-HPST*CFE2
8934          PT2(2) = PT2I(2)-HPST*SFE2
8935       ENDIF
8936
8937 * put partons on mass shell
8938       XMP1 = 0.0D0
8939       XMT1 = 0.0D0
8940       IF (JMSHL.EQ.1) THEN
8941
8942          XMP1 = PYMASS(IFPR1)
8943          XMT1 = PYMASS(IFTA1)
8944
8945       ENDIF
8946       CALL DT_MASHEL(PP1,PT1,XMP1,XMT1,P1,P2,IREJ1)
8947       IF (IREJ1.NE.0) GOTO 2
8948       DO 3 I=1,4
8949          PTOTF(I) = P1(I)+P2(I)
8950          PP1(I)   = P1(I)
8951          PT1(I)   = P2(I)
8952     3 CONTINUE
8953       XMP2 = 0.0D0
8954       XMT2 = 0.0D0
8955       IF (JMSHL.EQ.1) THEN
8956
8957          XMP2 = PYMASS(IFPR2)
8958          XMT2 = PYMASS(IFTA2)
8959
8960       ENDIF
8961       CALL DT_MASHEL(PP2,PT2,XMP2,XMT2,P1,P2,IREJ1)
8962       IF (IREJ1.NE.0) GOTO 2
8963       DO 4 I=1,4
8964          PTOTF(I) = PTOTF(I)+P1(I)+P2(I)
8965          PP2(I)   = P1(I)
8966          PT2(I)   = P2(I)
8967     4 CONTINUE
8968
8969 * check consistency
8970       DO 5 I=1,4
8971          DIFF(I) = PTOTI(I)-PTOTF(I)
8972     5 CONTINUE
8973       IF ((ABS(DIFF(1)).GT.TINY5).OR.(ABS(DIFF(2)).GT.TINY5).OR.
8974      &    (ABS(DIFF(3)).GT.TINY5).OR.(ABS(DIFF(4)).GT.TINY5)) THEN
8975          WRITE(LOUT,'(1X,A,4G10.3)') 'GETSPT: inconsistencies ',DIFF
8976          GOTO 9999
8977       ENDIF
8978       PTOTP1 = SQRT(PP1(1)**2+PP1(2)**2+PP1(3)**2)
8979       AMP1 = SQRT(ABS( (PP1(4)-PTOTP1)*(PP1(4)+PTOTP1) ))
8980       PTOTP2 = SQRT(PP2(1)**2+PP2(2)**2+PP2(3)**2)
8981       AMP2 = SQRT(ABS( (PP2(4)-PTOTP2)*(PP2(4)+PTOTP2) ))
8982       PTOTT1 = SQRT(PT1(1)**2+PT1(2)**2+PT1(3)**2)
8983       AMT1 = SQRT(ABS( (PT1(4)-PTOTT1)*(PT1(4)+PTOTT1) ))
8984       PTOTT2 = SQRT(PT2(1)**2+PT2(2)**2+PT2(3)**2)
8985       AMT2 = SQRT(ABS( (PT2(4)-PTOTT2)*(PT2(4)+PTOTT2) ))
8986       IF ((ABS(AMP1-XMP1).GT.TINY3).OR.(ABS(AMP2-XMP2).GT.TINY3).OR.
8987      &    (ABS(AMT1-XMT1).GT.TINY3).OR.(ABS(AMT2-XMT2).GT.TINY3))
8988      &                                                           THEN
8989          WRITE(LOUT,'(1X,A,2(4G10.3,/))')
8990      &     'GETSPT: inconsistent masses',
8991      &     AMP1,XMP1,AMP2,XMP2,AMT1,XMT1,AMT2,XMT2
8992 * sr 22.11.00: commented. It should only have inconsistent masses for
8993 * ultrahigh energies due to rounding problems
8994 C        GOTO 9999
8995       ENDIF
8996
8997 * get chain masses
8998       PTOCH = SQRT((PP1(1)+PT1(1))**2+(PP1(2)+PT1(2))**2
8999      &                               +(PP1(3)+PT1(3))**2)
9000       ECH   = PP1(4)+PT1(4)
9001       AM1N  = (ECH+PTOCH)*(ECH-PTOCH)
9002       PTOCH = SQRT((PP2(1)+PT2(1))**2+(PP2(2)+PT2(2))**2
9003      &                               +(PP2(3)+PT2(3))**2)
9004       ECH   = PP2(4)+PT2(4)
9005       AM2N  = (ECH+PTOCH)*(ECH-PTOCH)
9006       IF ((AM1N.LT.0.0D0).OR.(AM2N.LT.0.0D0)) THEN
9007          IF (IOULEV(1).GT.0)
9008      &   WRITE(LOUT,'(1X,A,2G10.3)')'GETSPT: too small chain masses 2',
9009      &                              AM1N,AM2N
9010          GOTO 2
9011       ENDIF
9012       AM1N = SQRT(AM1N)
9013       AM2N = SQRT(AM2N)
9014
9015 * check chain masses for very low mass chains
9016       CALL DT_CH2RES(IFP1(1),IFP1(2),IFT1(1),IFT1(2),IDUM,IDUM,
9017      &            AM1N,DUM,-IDCH1,IREJ1)
9018       IF (IREJ1.NE.0) GOTO 2
9019       CALL DT_CH2RES(IFP2(1),IFP2(2),IFT2(1),IFT2(2),IDUM,IDUM,
9020      &            AM2N,DUM,-IDCH2,IREJ2)
9021       IF (IREJ2.NE.0) GOTO 2
9022
9023     7 CONTINUE
9024       IF (AM1N.GT.ZERO) THEN
9025          AM1 = AM1N
9026          AM2 = AM2N
9027       ENDIF
9028       DO 6 I=1,4
9029          PP1I(I)   = PP1(I)
9030          PP2I(I)   = PP2(I)
9031          PT1I(I)   = PT1(I)
9032          PT2I(I)   = PT2(I)
9033     6 CONTINUE
9034
9035       RETURN
9036
9037  9999 CONTINUE
9038       IREJ = 1
9039       RETURN
9040       END
9041
9042 *$ CREATE DT_SAPTRE.FOR
9043 *COPY DT_SAPTRE
9044 *
9045 *===saptre=============================================================*
9046 *
9047       SUBROUTINE DT_SAPTRE(IDX1,IDX2)
9048
9049 ************************************************************************
9050 * p-t sampling for two-resonance systems. ("BAMJET-like" method)       *
9051 *        IDX1,IDX2       indices of resonances ("chains") in DTEVT1    *
9052 * Adopted from the original SAPTRE written by J. Ranft.                *
9053 * This version dated 18.01.95 is written by S. Roesler                 *
9054 ************************************************************************
9055
9056       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9057       SAVE
9058
9059       PARAMETER ( LINP = 10 ,
9060      &            LOUT = 6 ,
9061      &            LDAT = 9 )
9062
9063       PARAMETER (TINY7=1.0D-7,TINY3=1.0D-3)
9064
9065 * event history
9066
9067       PARAMETER (NMXHKK=200000)
9068
9069       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9070      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9071      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9072
9073 * extended event history
9074       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9075      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9076      &                IHIST(2,NMXHKK)
9077
9078 * flags for input different options
9079       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9080       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9081      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9082
9083       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
9084
9085       DATA B3 /4.0D0/
9086
9087       ESMAX1 = PHKK(4,IDX1)-PHKK(5,IDX1)
9088       ESMAX2 = PHKK(4,IDX2)-PHKK(5,IDX2)
9089       ESMAX  = MIN(ESMAX1,ESMAX2)
9090       IF (ESMAX.LE.0.05D0) RETURN
9091
9092       HMA    = PHKK(5,IDX1)
9093       DO 1 K=1,4
9094          PA1(K) = PHKK(K,IDX1)
9095          PA2(K) = PHKK(K,IDX2)
9096     1 CONTINUE
9097
9098       IF (LEMCCK) THEN
9099          CALL DT_EVTEMC(PA1(1),PA1(2),PA1(3),PA1(4),1,IDUM,IDUM)
9100          CALL DT_EVTEMC(PA2(1),PA2(2),PA2(3),PA2(4),2,IDUM,IDUM)
9101       ENDIF
9102
9103       EXEB   = 0.0D0
9104       IF (B3*ESMAX.LE.60.0D0) EXEB = EXP(-B3*ESMAX)
9105       BEXP   = HMA*(1.0D0-EXEB)/B3
9106       AXEXP  = (1.0D0-(B3*ESMAX-1.0D0)*EXEB)/B3**2
9107       WA     = AXEXP/(BEXP+AXEXP)
9108       XAB    = DT_RNDM(WA)
9109    10 CONTINUE
9110 * ES is the transverse kinetic energy
9111       IF (XAB.LT.WA)THEN
9112         X  = DT_RNDM(WA)
9113         Y  = DT_RNDM(WA)
9114         ES = -2.0D0/(B3**2)*LOG(X*Y+TINY7)
9115       ELSE
9116         X  = DT_RNDM(Y)
9117         ES = ABS(-LOG(X+TINY7)/B3)
9118       ENDIF
9119       IF (ES.GT.ESMAX) GOTO 10
9120       ES  = ES+HMA
9121 * transverse momentum
9122       HPS = SQRT((ES-HMA)*(ES+HMA))
9123
9124       CALL DT_DSFECF(SFE,CFE)
9125       HPX = HPS*CFE
9126       HPY = HPS*SFE
9127       PZ1NSQ = PA1(3)**2-HPS**2-2.0D0*PA1(1)*HPX-2.0D0*PA1(2)*HPY
9128       PZ2NSQ = PA2(3)**2-HPS**2+2.0D0*PA2(1)*HPX+2.0D0*PA2(2)*HPY
9129       IF ((PZ1NSQ.LT.TINY3).OR.(PZ2NSQ.LT.TINY3)) RETURN
9130
9131 C     PA1(3) = SIGN(SQRT(PZ1NSQ),PA1(3))
9132 C     PA2(3) = SIGN(SQRT(PZ2NSQ),PA2(3))
9133       PA1(1) = PA1(1)+HPX
9134       PA1(2) = PA1(2)+HPY
9135       PA2(1) = PA2(1)-HPX
9136       PA2(2) = PA2(2)-HPY
9137
9138 * put resonances on mass-shell again
9139       XM1 = PHKK(5,IDX1)
9140       XM2 = PHKK(5,IDX2)
9141       CALL DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ1)
9142       IF (IREJ1.NE.0) RETURN
9143
9144       IF (LEMCCK) THEN
9145          CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,IDUM,IDUM)
9146          CALL DT_EVTEMC(-P2(1),-P2(2),-P2(3),-P2(4),2,IDUM,IDUM)
9147          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,12,IREJ1)
9148          IF (IREJ1.NE.0) RETURN
9149       ENDIF
9150
9151       DO 2 K=1,4
9152          PHKK(K,IDX1) = P1(K)
9153          PHKK(K,IDX2) = P2(K)
9154     2 CONTINUE
9155
9156       RETURN
9157       END
9158
9159 *$ CREATE DT_CRONIN.FOR
9160 *COPY DT_CRONIN
9161 *
9162 *===cronin=============================================================*
9163 *
9164       SUBROUTINE DT_CRONIN(INCL)
9165
9166 ************************************************************************
9167 * Cronin-Effect. Multiple scattering of partons at chain ends.         *
9168 *             INCL = 1     multiple sc. in projectile                  *
9169 *                  = 2     multiple sc. in target                      *
9170 * This version dated 05.01.96 is written by S. Roesler.                *
9171 ************************************************************************
9172
9173       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9174       SAVE
9175
9176       PARAMETER ( LINP = 10 ,
9177      &            LOUT = 6 ,
9178      &            LDAT = 9 )
9179
9180       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9181
9182 * event history
9183
9184       PARAMETER (NMXHKK=200000)
9185
9186       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9187      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9188      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9189
9190 * extended event history
9191       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9192      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9193      &                IHIST(2,NMXHKK)
9194
9195 * rejection counter
9196       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9197      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9198      &                IREXCI(3),IRDIFF(2),IRINC
9199
9200 * Glauber formalism: collision properties
9201       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9202      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
9203
9204       DIMENSION R(3),PIN(4),POUT(4),DEV(4)
9205
9206       DO 1 K=1,4
9207          DEV(K) = ZERO
9208     1 CONTINUE
9209
9210       DO 2 I=NPOINT(2),NHKK
9211          IF (ISTHKK(I).LT.0) THEN
9212 * get z-position of the chain
9213             R(1) = VHKK(1,I)*1.0D12
9214             IF (INCL.EQ.2) R(1) = VHKK(1,I)*1.0D12-BIMPAC
9215             R(2) = VHKK(2,I)*1.0D12
9216             IDXNU = JMOHKK(1,I)
9217             IF ( (INCL.EQ.1).AND.(ISTHKK(IDXNU).EQ.10) )
9218      &                             IDXNU = JMOHKK(1,I-1)
9219             IF ( (INCL.EQ.2).AND.(ISTHKK(IDXNU).EQ. 9) )
9220      &                             IDXNU = JMOHKK(1,I+1)
9221             R(3) = VHKK(3,IDXNU)*1.0D12
9222 * position of target parton the chain is connected to
9223             DO 3 K=1,4
9224                PIN(K) = PHKK(K,I)
9225     3       CONTINUE
9226 * multiple scattering of parton with DTEVT1-index I
9227             CALL DT_CROMSC(PIN,R,POUT,INCL)
9228 **testprint
9229 C           IF (NEVHKK.EQ.5) THEN
9230 C              AMIN = PIN(4)**2-PIN(1)**2-PIN(2)**2-PIN(3)**2
9231 C              AMOU = POUT(4)**2-POUT(1)**2-POUT(2)**2-POUT(3)**2
9232 C              AMIN = SIGN(SQRT(ABS(AMIN)),AMIN)
9233 C              AMOU = SIGN(SQRT(ABS(AMOU)),AMOU)
9234 C              WRITE(6,'(A,I4,2E15.5)')'I,AMIN,AMOU: ',I,AMIN,AMOU
9235 C              WRITE(6,'(A,4E15.5)')'PIN:       ',PIN
9236 C              WRITE(6,'(A,4E15.5)')'POUT:      ',POUT
9237 C           ENDIF
9238 **
9239 * increase accumulator by energy-momentum difference
9240             DO 4 K=1,4
9241                DEV(K)    = DEV(K)+POUT(K)-PIN(K)
9242                PHKK(K,I) = POUT(K)
9243     4       CONTINUE
9244             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9245      &                           PHKK(2,I)**2-PHKK(3,I)**2))
9246          ENDIF
9247     2 CONTINUE
9248
9249 * dump accumulator to momenta of valence partons
9250       NVAL = 0
9251       ETOT = 0.0D0
9252       DO 5 I=NPOINT(2),NHKK
9253          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9254             NVAL = NVAL+1
9255             ETOT = ETOT+PHKK(4,I)
9256          ENDIF
9257     5 CONTINUE
9258 C     WRITE(LOUT,1000) NVAL,(DEV(K)/DBLE(NVAL),K=1,4)
9259  1000 FORMAT(1X,'CRONIN :  number of val. partons ',I4,/,
9260      &       9X,4E12.4)
9261       DO 6 I=NPOINT(2),NHKK
9262          IF ((ISTHKK(I).EQ.-21).OR.(ISTHKK(I).EQ.-22)) THEN
9263             E = PHKK(4,I)
9264             DO 7 K=1,4
9265 C              PHKK(K,I) = PHKK(K,I)-DEV(K)/DBLE(NVAL)
9266                PHKK(K,I) = PHKK(K,I)-DEV(K)*E/ETOT
9267     7       CONTINUE
9268             PHKK(5,I) = SQRT(ABS(PHKK(4,I)**2-PHKK(1,I)**2-
9269      &                           PHKK(2,I)**2-PHKK(3,I)**2))
9270          ENDIF
9271     6 CONTINUE
9272
9273       RETURN
9274       END
9275
9276 *$ CREATE DT_CROMSC.FOR
9277 *COPY DT_CROMSC
9278 *
9279 *===cromsc=============================================================*
9280 *
9281       SUBROUTINE DT_CROMSC(PIN,R,POUT,INCL)
9282
9283 ************************************************************************
9284 * Cronin-Effect. Multiple scattering of one parton passing through     *
9285 * nuclear matter.                                                      *
9286 *            PIN(4)       input 4-momentum of parton                   *
9287 *            POUT(4)      4-momentum of parton after mult. scatt.      *
9288 *            R(3)         spatial position of parton in target nucleus *
9289 *            INCL = 1     multiple sc. in projectile                   *
9290 *                 = 2     multiple sc. in target                       *
9291 * This is a revised version of the original version written by J. Ranft*
9292 * This version dated 17.01.95 is written by S. Roesler.                *
9293 ************************************************************************
9294
9295       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9296       SAVE
9297
9298       PARAMETER ( LINP = 10 ,
9299      &            LOUT = 6 ,
9300      &            LDAT = 9 )
9301
9302       PARAMETER (ZERO=0.0D0,TINY3=1.0D-3)
9303
9304       LOGICAL LSTART
9305
9306 * rejection counter
9307       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
9308      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
9309      &                IREXCI(3),IRDIFF(2),IRINC
9310
9311 * Glauber formalism: collision properties
9312       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
9313      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
9314
9315 * various options for treatment of partons (DTUNUC 1.x)
9316 * (chain recombination, Cronin,..)
9317       LOGICAL LCO2CR,LINTPT
9318       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9319      &                LCO2CR,LINTPT
9320
9321       DIMENSION PIN(4),POUT(4),R(3)
9322
9323       DATA LSTART /.TRUE./
9324
9325       IRCRON(1) = IRCRON(1)+1
9326
9327       IF (LSTART) THEN
9328          WRITE(LOUT,1000) CRONCO
9329  1000    FORMAT(/,1X,'CROMSC:  multiple scattering of chain ends',
9330      &          ' treated',/,10X,'with parameter CRONCO = ',F5.2)
9331          LSTART = .FALSE.
9332       ENDIF
9333
9334       NCBACK = 0
9335       RNCL   = RPROJ
9336       IF (INCL.EQ.2) RNCL = RTARG
9337
9338 * Lorentz-transformation into Lab.
9339       MODE = -(INCL+1)
9340       CALL DT_LTNUC(PIN(3),PIN(4),PZ,PE,MODE)
9341
9342       PTOT = SQRT(PIN(1)**2+PIN(2)**2+PZ**2)
9343       IF (PTOT.LE.8.0D0) GOTO 9997
9344
9345 * direction cosines of parton before mult. scattering
9346       COSX = PIN(1)/PTOT
9347       COSY = PIN(2)/PTOT
9348       COSZ = PZ/PTOT
9349
9350       RTESQ = R(1)**2+R(2)**2+R(3)**2-RNCL**2
9351       IF (RTESQ.GE.-TINY3) GOTO 9999
9352
9353 * calculate distance (DIST) from R to surface of nucleus (radius RNCL)
9354 * in the direction of particle motion
9355
9356       A    = COSX*R(1)+COSY*R(2)+COSZ*R(3)
9357       TMP  = A**2-RTESQ
9358       IF (TMP.LT.ZERO) GOTO 9998
9359       DIST = -A+SQRT(TMP)
9360
9361 * multiple scattering angle
9362       THETO = CRONCO*SQRT(DIST)/PTOT
9363       IF (THETO.GT.0.1D0) THETO=0.1D0
9364
9365     1 CONTINUE
9366 * Gaussian sampling of spatial angle
9367       CALL DT_RANNOR(R1,R2)
9368       THETA = ABS(R1*THETO)
9369       IF (THETA.GT.0.3D0) GOTO 9997
9370       CALL DT_DSFECF(SFE,CFE)
9371       COSTH = COS(THETA)
9372       SINTH = SIN(THETA)
9373
9374 * new direction cosines
9375       CALL DT_MYTRAN(1,COSX,COSY,COSZ,COSTH,SINTH,SFE,CFE,
9376      &                               COSXN,COSYN,COSZN)
9377
9378       POUT(1) = COSXN*PTOT
9379       POUT(2) = COSYN*PTOT
9380       PZ      = COSZN*PTOT
9381 * Lorentz-transformation into nucl.-nucl. cms
9382       MODE = INCL+1
9383       CALL DT_LTNUC(PZ,PE,POUT(3),POUT(4),MODE)
9384
9385 C     IF (ABS(PIN(4)-POUT(4)).GT.0.2D0) THEN
9386 C     IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.1D0 ) THEN
9387       IF ( (ABS(PIN(4)-POUT(4))/PIN(4)).GT.0.05D0 ) THEN
9388          THETO = THETO/2.0D0
9389          NCBACK = NCBACK+1
9390          IF (MOD(NCBACK,200).EQ.0) THEN
9391             WRITE(LOUT,1001) THETO,PIN,POUT
9392  1001       FORMAT(1X,'CROMSC: inconsistent scattering angle ',
9393      &             E12.4,/,1X,'        PIN :',4E12.4,/,
9394      &             1X,'       POUT:',4E12.4)
9395             GOTO 9997
9396          ENDIF
9397          GOTO 1
9398       ENDIF
9399
9400       RETURN
9401
9402  9997 IRCRON(2) = IRCRON(2)+1
9403       GOTO 9999
9404  9998 IRCRON(3) = IRCRON(3)+1
9405
9406  9999 CONTINUE
9407       DO 100 K=1,4
9408          POUT(K) = PIN(K)
9409   100 CONTINUE
9410       RETURN
9411       END
9412
9413 *$ CREATE DT_COM2CR.FOR
9414 *COPY DT_COM2CR
9415 *
9416 *===com2sr=============================================================*
9417 *
9418       SUBROUTINE DT_COM2CR
9419
9420 ************************************************************************
9421 * COMbine q-aq chains to Color Ropes (qq-aqaq).                        *
9422 *        CUTOF      parameter determining minimum number of not        *
9423 *                   combined q-aq chains                               *
9424 * This subroutine replaces KKEVCC etc.                                 *
9425 * This version dated 11.01.95 is written by S. Roesler.                *
9426 ************************************************************************
9427
9428       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9429       SAVE
9430
9431       PARAMETER ( LINP = 10 ,
9432      &            LOUT = 6 ,
9433      &            LDAT = 9 )
9434
9435 * event history
9436
9437       PARAMETER (NMXHKK=200000)
9438
9439       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9440      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9441      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9442
9443 * extended event history
9444       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9445      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9446      &                IHIST(2,NMXHKK)
9447
9448 * statistics
9449       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9450      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9451      &                ICEVTG(8,0:30)
9452
9453 * various options for treatment of partons (DTUNUC 1.x)
9454 * (chain recombination, Cronin,..)
9455       LOGICAL LCO2CR,LINTPT
9456       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
9457      &                LCO2CR,LINTPT
9458
9459       DIMENSION IDXQA(248),IDXAQ(248)
9460
9461       ICCHAI(1,9) = ICCHAI(1,9)+1
9462       NQA = 0
9463       NAQ = 0
9464 * scan DTEVT1 for q-aq, aq-q chains
9465       DO 10 I=NPOINT(3),NHKK
9466 * skip "chains" which are resonances
9467          IF ((IDHKK(I).EQ.88888).AND.(IDRES(I).EQ.0)) THEN
9468             MO1 = JMOHKK(1,I)
9469             MO2 = JMOHKK(2,I)
9470             IF ((ABS(IDHKK(MO1)).LE.6).AND.(ABS(IDHKK(MO2)).LE.6)) THEN
9471 * q-aq, aq-q chain found, keep index
9472                IF (IDHKK(MO1).GT.0) THEN
9473                   NQA = NQA+1
9474                   IDXQA(NQA) = I
9475                ELSE
9476                   NAQ = NAQ+1
9477                   IDXAQ(NAQ) = I
9478                ENDIF
9479             ENDIF
9480          ENDIF
9481    10 CONTINUE
9482
9483 * minimum number of q-aq chains requested for the same projectile/
9484 * target
9485       NCHMIN = IDT_NPOISS(CUTOF)
9486
9487 * combine q-aq chains of the same projectile
9488       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,1)
9489 * combine q-aq chains of the same target
9490       CALL DT_SCN4CR(NQA,IDXQA,NCHMIN,2)
9491 * combine aq-q chains of the same projectile
9492       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,1)
9493 * combine aq-q chains of the same target
9494       CALL DT_SCN4CR(NAQ,IDXAQ,NCHMIN,2)
9495
9496       RETURN
9497       END
9498
9499 *$ CREATE DT_SCN4CR.FOR
9500 *COPY DT_SCN4CR
9501 *
9502 *===scn4cr=============================================================*
9503 *
9504       SUBROUTINE DT_SCN4CR(NCH,IDXCH,NCHMIN,MODE)
9505
9506 ************************************************************************
9507 * SCan q-aq chains for Color Ropes.                                    *
9508 * This version dated 11.01.95 is written by S. Roesler.                *
9509 ************************************************************************
9510
9511       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9512       SAVE
9513
9514       PARAMETER ( LINP = 10 ,
9515      &            LOUT = 6 ,
9516      &            LDAT = 9 )
9517
9518 * event history
9519
9520       PARAMETER (NMXHKK=200000)
9521
9522       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9523      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9524      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9525
9526 * extended event history
9527       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9528      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9529      &                IHIST(2,NMXHKK)
9530
9531       DIMENSION IDXCH(248),IDXJN(248)
9532
9533       DO 1 I=1,NCH
9534          IF (IDXCH(I).GT.0) THEN
9535             NJOIN = 1
9536             IDXMO = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(I))))
9537             IDXJN(NJOIN) = I
9538             IF (I.LT.NCH) THEN
9539                DO 2 J=I+1,NCH
9540                   IF (IDXCH(J).GT.0) THEN
9541                      IDXMO1 = JMOHKK(1,JMOHKK(1,JMOHKK(MODE,IDXCH(J))))
9542                      IF (IDXMO.EQ.IDXMO1) THEN
9543                         NJOIN = NJOIN+1
9544                         IDXJN(NJOIN) = J
9545                      ENDIF
9546                   ENDIF
9547     2          CONTINUE
9548             ENDIF
9549             IF (NJOIN.GE.NCHMIN+2) THEN
9550                NJ = INT(DBLE(NJOIN-NCHMIN)/2.0D0)
9551                DO 3 J=1,2*NJ,2
9552                   CALL DT_JOIN(IDXCH(IDXJN(J)),IDXCH(IDXJN(J+1)),IREJ1)
9553                   IF (IREJ1.NE.0) GOTO 3
9554                   IDXCH(IDXJN(J))   = 0
9555                   IDXCH(IDXJN(J+1)) = 0
9556     3          CONTINUE
9557             ENDIF
9558          ENDIF
9559     1 CONTINUE
9560
9561       RETURN
9562       END
9563
9564 *$ CREATE DT_JOIN.FOR
9565 *COPY DT_JOIN
9566 *
9567 *===join===============================================================*
9568 *
9569       SUBROUTINE DT_JOIN(IDX1,IDX2,IREJ)
9570
9571 ************************************************************************
9572 * This subroutine joins two q-aq chains to one qq-aqaq chain.          *
9573 *     IDX1, IDX2       DTEVT1 indices of chains to be joined           *
9574 * This version dated 11.01.95 is written by S. Roesler.                *
9575 ************************************************************************
9576
9577       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9578       SAVE
9579
9580       PARAMETER ( LINP = 10 ,
9581      &            LOUT = 6 ,
9582      &            LDAT = 9 )
9583
9584 * event history
9585
9586       PARAMETER (NMXHKK=200000)
9587
9588       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
9589      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
9590      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
9591
9592 * extended event history
9593       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
9594      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
9595      &                IHIST(2,NMXHKK)
9596
9597 * flags for input different options
9598       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
9599       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
9600      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
9601
9602 * statistics
9603       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
9604      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
9605      &                ICEVTG(8,0:30)
9606
9607       DIMENSION MO(2,2),ID(2,2),IDX(2),PCH(4),PP(4),PT(4),P1(4),P2(4)
9608
9609       IREJ   = 0
9610
9611       IDX(1) = IDX1
9612       IDX(2) = IDX2
9613       DO 1 I=1,2
9614          DO 2 J=1,2
9615             MO(I,J) = JMOHKK(J,IDX(I))
9616             ID(I,J) = IDT_IPDG2B(IDHKK(MO(I,J)),1,2)
9617     2    CONTINUE
9618     1 CONTINUE
9619
9620 * check consistency
9621       IF ((ABS(ID(1,1)).GT.6).OR.(ABS(ID(1,2)).GT.6).OR.
9622      &    (ABS(ID(2,1)).GT.6).OR.(ABS(ID(2,2)).GT.6).OR.
9623      &    ((ID(1,1)*ID(2,1)).LT.0).OR.
9624      &    ((ID(1,2)*ID(2,2)).LT.0)) THEN
9625          WRITE(LOUT,1000) IDX(1),MO(1,1),MO(1,2),IDX(2),MO(2,1),
9626      &                    MO(2,2)
9627  1000    FORMAT(1X,'JOIN: incons. chain system! chain ',I4,':',
9628      &             2I5,' chain ',I4,':',2I5)
9629       ENDIF
9630
9631 * join chains
9632       DO 3 K=1,4
9633          PP(K) = PHKK(K,MO(1,1))+PHKK(K,MO(2,1))
9634          PT(K) = PHKK(K,MO(1,2))+PHKK(K,MO(2,2))
9635     3 CONTINUE
9636       IF1  = IDT_IB2PDG(ID(1,1),ID(2,1),2)
9637       IF2  = IDT_IB2PDG(ID(1,2),ID(2,2),2)
9638       IST1 = ISTHKK(MO(1,1))
9639       IST2 = ISTHKK(MO(1,2))
9640
9641 * put partons again on mass shell
9642       XM1 = 0.0D0
9643       XM2 = 0.0D0
9644       IF (IMSHL.EQ.1) THEN
9645
9646          XM1 = PYMASS(IF1)
9647          XM2 = PYMASS(IF2)
9648
9649       ENDIF
9650       CALL DT_MASHEL(PP,PT,XM1,XM2,P1,P2,IREJ1)
9651       IF (IREJ1.NE.0) GOTO 9999
9652       DO 4 I=1,4
9653          PP(I) = P1(I)
9654          PT(I) = P2(I)
9655     4 CONTINUE
9656
9657 * store new partons in DTEVT1
9658       CALL DT_EVTPUT(IST1,IF1,MO(1,1),MO(2,1),PP(1),PP(2),PP(3),PP(4),
9659      &                                                       0,0,0)
9660       CALL DT_EVTPUT(IST2,IF2,MO(1,2),MO(2,2),PT(1),PT(2),PT(3),PT(4),
9661      &                                                       0,0,0)
9662       DO 5 K=1,4
9663          PCH(K) = PP(K)+PT(K)
9664     5 CONTINUE
9665
9666 * check new chain for lower mass limit
9667       IF ((IRESCO.EQ.1).OR.(IFRAG(1).EQ.1)) THEN
9668          AMCH = SQRT(ABS(PCH(4)**2-PCH(1)**2-PCH(2)**2-PCH(3)**2))
9669          CALL DT_CH2RES(ID(1,1),ID(2,1),ID(1,2),ID(2,2),IDUM,IDUM,
9670      &               AMCH,AMCHN,3,IREJ1)
9671          IF (IREJ1.NE.0) THEN
9672             NHKK = NHKK-2
9673             GOTO 9999
9674          ENDIF
9675       ENDIF
9676
9677       ICCHAI(2,9) = ICCHAI(2,9)+1
9678 * store new chain in DTEVT1
9679       KCH = 191
9680       CALL DT_EVTPUT(KCH,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),0,0,9)
9681       IDHKK(IDX(1)) = 22222
9682       IDHKK(IDX(2)) = 22222
9683 * special treatment for space-time coordinates
9684       DO 6 K=1,4
9685          VHKK(K,NHKK) = (VHKK(K,IDX(1))+VHKK(K,IDX(2)))/2.0D0
9686          WHKK(K,NHKK) = (WHKK(K,IDX(1))+WHKK(K,IDX(2)))/2.0D0
9687     6 CONTINUE
9688       RETURN
9689
9690  9999 CONTINUE
9691       IREJ = 1
9692       RETURN
9693       END
9694 *$ CREATE DT_XSGLAU.FOR
9695 *COPY DT_XSGLAU
9696 *
9697 *===xsglau=============================================================*
9698 *
9699       SUBROUTINE DT_XSGLAU(NA,NB,JJPROJ,XI,Q2I,ECMI,IE,IQ,NIDX)
9700
9701 ************************************************************************
9702 * Total, elastic, quasi-elastic, inelastic cross sections according to *
9703 * Glauber's approach.                                                  *
9704 *  NA / NB     mass numbers of proj./target nuclei                     *
9705 *  JJPROJ      bamjet-index of projectile (=1 in case of proj.nucleus) *
9706 *  XI,Q2I,ECMI kinematical variables x, Q^2, E_cm                      *
9707 *  IE,IQ       indices of energy and virtuality (the latter for gamma  *
9708 *              projectiles only)                                       *
9709 *  NIDX        index of projectile/target nucleus                      *
9710 * This version dated 17.3.98  is written by S. Roesler                 *
9711 ************************************************************************
9712
9713       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
9714       SAVE
9715
9716       PARAMETER ( LINP = 10 ,
9717      &            LOUT = 6 ,
9718      &            LDAT = 9 )
9719
9720       COMPLEX*16 CZERO,CONE,CTWO
9721       CHARACTER*12 CFILE
9722       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
9723      &           ONETHI=ONE/THREE,TINY25=1.0D-25)
9724       PARAMETER (TWOPI  = 6.283185307179586454D+00,
9725      &           PI     = TWOPI/TWO,
9726      &           GEV2MB = 0.38938D0,
9727      &           GEV2FM = 0.1972D0,
9728      &           ALPHEM = ONE/137.0D0,
9729 * proton mass
9730      &           AMP    = 0.938D0,
9731      &           AMP2   = AMP**2,
9732 * approx. nucleon radius
9733      &           RNUCLE = 1.12D0)
9734
9735 * particle properties (BAMJET index convention)
9736       CHARACTER*8  ANAME
9737       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
9738      &                IICH(210),IIBAR(210),K1(210),K2(210)
9739
9740       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
9741
9742       PARAMETER ( MAXNCL = 260,
9743
9744      &            MAXVQU = MAXNCL,
9745      &            MAXSQU = 20*MAXVQU,
9746      &            MAXINT = MAXVQU+MAXSQU)
9747
9748 * Glauber formalism: parameters
9749       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
9750      &                BMAX(NCOMPX),BSTEP(NCOMPX),
9751      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
9752      &                NSITEB,NSTATB
9753
9754 * Glauber formalism: cross sections
9755       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
9756      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
9757      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
9758      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
9759      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
9760      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
9761      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
9762      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
9763      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
9764      &                BSLOPE,NEBINI,NQBINI
9765
9766 * Glauber formalism: flags and parameters for statistics
9767       LOGICAL LPROD
9768       CHARACTER*8 CGLB
9769       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
9770
9771 * nucleon-nucleon event-generator
9772       CHARACTER*8 CMODEL
9773       LOGICAL LPHOIN
9774       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
9775
9776 * VDM parameter for photon-nucleus interactions
9777       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
9778
9779 * parameters for hA-diffraction
9780       COMMON /DTDIHA/ DIBETA,DIALPH
9781
9782       COMPLEX*16 PP11(MAXNCL),PP12(MAXNCL),PP21(MAXNCL),PP22(MAXNCL),
9783      &           OMPP11,OMPP12,OMPP21,OMPP22,
9784      &           DIPP11,DIPP12,DIPP21,DIPP22,AVDIPP,
9785      &           PPTMP1,PPTMP2
9786       COMPLEX*16 C,CA,CI
9787       DIMENSION COOP1(3,MAXNCL),COOT1(3,MAXNCL),
9788      &          COOP2(3,MAXNCL),COOT2(3,MAXNCL),
9789      &          BPROD(KSITEB)
9790
9791       PARAMETER (NPOINT=16)
9792       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
9793
9794       LOGICAL LFIRST,LOPEN
9795       DATA LFIRST,LOPEN /.TRUE.,.FALSE./
9796
9797       NTARG = ABS(NIDX)
9798 * for quasi-elastic neutrino scattering set projectile to proton
9799 * it should not have an effect since the whole Glauber-formalism is
9800 * not needed for these interactions..
9801       IF (MCGENE.EQ.4) THEN
9802          IJPROJ = 1
9803       ELSE
9804          IJPROJ = JJPROJ
9805       ENDIF
9806
9807       IF ((ABS(IOGLB).EQ.1).AND.(.NOT.LOPEN)) THEN
9808          I = INDEX(CGLB,' ')
9809          IF (I.EQ.0) THEN
9810             CFILE = CGLB//'.glb'
9811             OPEN(LDAT,FILE=CGLB//'.glb',STATUS='UNKNOWN')
9812          ELSEIF (I.GT.1) THEN
9813             CFILE = CGLB(1:I-1)//'.glb'
9814             OPEN(LDAT,FILE=CGLB(1:I-1)//'.glb',STATUS='UNKNOWN')
9815          ELSE
9816             STOP 'XSGLAU 1'
9817          ENDIF
9818          LOPEN = .TRUE.
9819       ENDIF
9820
9821       CZERO  = DCMPLX(ZERO,ZERO)
9822       CONE   = DCMPLX(ONE,ZERO)
9823       CTWO   = DCMPLX(TWO,ZERO)
9824       NEBINI = IE
9825       NQBINI = IQ
9826
9827 * re-define kinematics
9828       S  = ECMI**2
9829       Q2 = Q2I
9830       X  = XI
9831 *  g(Q2=0)-A, h-A, A-A scattering
9832       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9833          Q2 = 0.0001D0
9834          X  = Q2/(S+Q2-AMP2)
9835 *  g(Q2>0)-A scattering
9836       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(S.GT.ZERO)) THEN
9837          X  = Q2/(S+Q2-AMP2)
9838       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(S.GT.ZERO)) THEN
9839          Q2 = (S-AMP2)*X/(ONE-X)
9840       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
9841          S  = Q2*(ONE-X)/X+AMP2
9842       ELSE
9843          WRITE(LOUT,*) 'XSGLAU: inconsistent input ',S,Q2,X
9844          STOP
9845       ENDIF
9846       ECMNN(IE) = SQRT(S)
9847       Q2G(IQ)   = Q2
9848       XNU = (S+Q2-AMP2)/(TWO*AMP)
9849
9850 * parameters determining statistics in evaluating Glauber-xsection
9851       NSTATB = JSTATB
9852       NSITEB = JBINSB
9853       IF (NSITEB.GT.KSITEB) NSITEB = KSITEB
9854
9855 * set up interaction geometry (common /DTGLAM/)
9856 *  projectile/target radii
9857       RPRNCL = DT_RNCLUS(NA)
9858       RTANCL = DT_RNCLUS(NB)
9859       IF (IJPROJ.EQ.7) THEN
9860          RASH(1) = ZERO
9861          RBSH(NTARG) = RTANCL
9862          BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9863       ELSE
9864          IF (NIDX.LE.-1) THEN
9865             RASH(1)     = RPRNCL
9866             RBSH(NTARG) = RTANCL
9867             BMAX(NTARG) = 2.0D0*(RASH(1)+RBSH(NTARG))
9868          ELSE
9869             RASH(NTARG) = RPRNCL
9870             RBSH(1)     = RTANCL
9871             BMAX(NTARG) = 2.0D0*(RASH(NTARG)+RBSH(1))
9872          ENDIF
9873       ENDIF
9874 *  maximum impact-parameter
9875       BSTEP(NTARG)= BMAX(NTARG)/DBLE(NSITEB-1)
9876
9877 * slope, rho ( Re(f(0))/Im(f(0)) )
9878       IF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
9879          IF (MCGENE.EQ.2) THEN
9880             ZERO1 = ZERO
9881             CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,SDUM1,SDUM2,SDUM3,
9882      &                                                   BSLOPE,0)
9883          ELSE
9884             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
9885          ENDIF
9886          IF (ECMNN(IE).LE.3.0D0) THEN
9887             ROSH = -0.43D0
9888          ELSEIF ((ECMNN(IE).GT.3.0D0).AND.(ECMNN(IE).LE.50.D0)) THEN
9889             ROSH = -0.63D0+0.175D0*LOG(ECMNN(IE))
9890          ELSEIF (ECMNN(IE).GT.50.0D0) THEN
9891             ROSH = 0.1D0
9892          ENDIF
9893       ELSEIF (IJPROJ.EQ.7) THEN
9894          ROSH = 0.1D0
9895       ELSE
9896          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
9897          ROSH   = 0.01D0
9898       ENDIF
9899
9900 * projectile-nucleon xsection (in fm)
9901       IF (IJPROJ.EQ.7) THEN
9902          SIGSH = DT_SIGVP(X,Q2)/10.0D0
9903       ELSE
9904          ELAB  = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
9905          PLAB  = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
9906 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
9907          DUMZER = ZERO
9908          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
9909          SIGSH = SIGSH/10.0D0
9910       ENDIF
9911
9912 * parameters for projectile diffraction (hA scattering only)
9913       IF ((MCGENE.EQ.2).AND.(NA.EQ.1).AND.(NB.GT.1).AND.(IJPROJ.NE.7)
9914      &                               .AND.(DIBETA.GE.ZERO)) THEN
9915          ZERO1 = ZERO
9916          CALL DT_PHOXS(IJPROJ,1,ECMNN(IE),ZERO1,STOT,SDUM2,SDIF1,BDUM,0)
9917 C        DIBETA = SDIF1/STOT
9918          DIBETA = 0.2D0
9919          DIGAMM = SQRT(DIALPH**2+DIBETA**2)
9920          IF (DIBETA.LE.ZERO) THEN
9921             ALPGAM = ONE
9922          ELSE
9923             ALPGAM = DIALPH/DIGAMM
9924          ENDIF
9925          FACDI1 = ONE-ALPGAM
9926          FACDI2 = ONE+ALPGAM
9927          FACDI  = SQRT(FACDI1*FACDI2)
9928          WRITE(LOUT,*)'DIBETA,DIALPH,DIGAMM: ',DIBETA,DIALPH,DIGAMM
9929       ELSE
9930          DIBETA = -1.0D0
9931          DIALPH = ZERO
9932          DIGAMM = ZERO
9933          FACDI1 = ZERO
9934          FACDI2 = 2.0D0
9935          FACDI  = ZERO
9936       ENDIF
9937
9938 * initializations
9939       DO 10 I=1,NSITEB
9940          BSITE( 0,IQ,NTARG,I) = ZERO
9941          BSITE(IE,IQ,NTARG,I) = ZERO
9942          BPROD(I) = ZERO
9943    10 CONTINUE
9944       STOT  = ZERO
9945       STOT2 = ZERO
9946       SELA  = ZERO
9947       SELA2 = ZERO
9948       SQEP  = ZERO
9949       SQEP2 = ZERO
9950       SQET  = ZERO
9951       SQET2 = ZERO
9952       SQE2  = ZERO
9953       SQE22 = ZERO
9954       SPRO  = ZERO
9955       SPRO2 = ZERO
9956       SDEL  = ZERO
9957       SDEL2 = ZERO
9958       SDQE  = ZERO
9959       SDQE2 = ZERO
9960       FACN   = ONE/DBLE(NSTATB)
9961
9962       IPNT = 0
9963       RPNT = ZERO
9964
9965 *  initialize Gauss-integration for photon-proj.
9966       JPOINT = 1
9967       IF (IJPROJ.EQ.7) THEN
9968          IF (INTRGE(1).EQ.1) THEN
9969             AMLO2 = (3.0D0*AAM(13))**2
9970          ELSEIF (INTRGE(1).EQ.2) THEN
9971             AMLO2 = AAM(33)**2
9972          ELSE
9973             AMLO2 = AAM(96)**2
9974          ENDIF
9975          IF (INTRGE(2).EQ.1) THEN
9976             AMHI2 = S/TWO
9977          ELSEIF (INTRGE(2).EQ.2) THEN
9978             AMHI2 = S/4.0D0
9979          ELSE
9980             AMHI2 = S
9981          ENDIF
9982          AMHI20 = (ECMNN(IE)-AMP)**2
9983          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
9984          XAMLO = LOG( AMLO2+Q2 )
9985          XAMHI = LOG( AMHI2+Q2 )
9986 **PHOJET105a
9987 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9988 **PHOJET112
9989
9990          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
9991
9992 **
9993          JPOINT = NPOINT
9994 * ratio direct/total photon-nucleon xsection
9995          CALL DT_POILIK(NB,NTARG,ECMNN(IE),Q2,IPNT,RPNT,1)
9996       ENDIF
9997
9998 * read pre-initialized profile-function from file
9999       IF (IOGLB.EQ.1) THEN
10000          READ(LDAT,'(5I10,E15.5)') KJPROJ,IA,IB,ISTATB,ISITEB,DUM
10001          IF ((IA.NE.NA).OR.(IB.NE.NB)) THEN
10002             WRITE(LOUT,1000) CFILE,IA,IB,ISTATB,ISITEB,
10003      &                             NA,NB,NSTATB,NSITEB
10004  1000       FORMAT(' XSGLAU: inconsistent input data in file ',A12,/,
10005      &             ' (IA,IB,ISTATB,ISITEB) ',4I10,/,
10006      &             ' (NA,NB,NSTATB,NSITEB) ',4I10)
10007             STOP
10008          ENDIF
10009          IF (LFIRST) WRITE(LOUT,1001) CFILE
10010  1001    FORMAT(/,' XSGLAU: impact parameter distribution read from ',
10011      &          'file ',A12,/)
10012          READ(LDAT,'(6E12.5)') XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),
10013      &                         XSQEP(IE,IQ,NTARG),XSQET(IE,IQ,NTARG),
10014      &                         XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10015          READ(LDAT,'(6E12.5)') XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),
10016      &                         XEQEP(IE,IQ,NTARG),XEQET(IE,IQ,NTARG),
10017      &                         XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10018          NLINES = INT(DBLE(NSITEB)/7.0D0)
10019          IF (NLINES.GT.0) THEN
10020             DO 21 I=1,NLINES
10021                ISTART = 7*I-6
10022                READ(LDAT,'(7E11.4)')
10023      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10024    21       CONTINUE
10025          ENDIF
10026          ISTART = 7*NLINES+1
10027          IF (ISTART.LE.NSITEB) THEN
10028             READ(LDAT,'(7E11.4)')
10029      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10030          ENDIF
10031          LFIRST = .FALSE.
10032          GOTO 100
10033 * variable projectile/target/energy runs:
10034 * read pre-initialized profile-functions from file
10035       ELSEIF (IOGLB.EQ.100) THEN
10036          CALL DT_GLBSET(IJPROJ,IINA,IINB,RRELAB,0)
10037          GOTO 100
10038       ENDIF
10039
10040 * cross sections averaged over NSTATB nucleon configurations
10041       DO 11 IS=1,NSTATB
10042 C        IF ((NA.EQ.207).AND.(NB.EQ.207)) WRITE(LOUT,*) 'conf. ',IS
10043          STOTN = ZERO
10044          SELAN = ZERO
10045          SQEPN = ZERO
10046          SQETN = ZERO
10047          SQE2N = ZERO
10048          SPRON = ZERO
10049          SDELN = ZERO
10050          SDQEN = ZERO
10051
10052          IF (NIDX.LE.-1) THEN
10053             CALL DT_CONUCL(COOP1,NA,RASH(1),0)
10054             CALL DT_CONUCL(COOT1,NB,RBSH(NTARG),1)
10055             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10056                CALL DT_CONUCL(COOP2,NA,RASH(1),0)
10057                CALL DT_CONUCL(COOT2,NB,RBSH(NTARG),1)
10058             ENDIF
10059          ELSE
10060             CALL DT_CONUCL(COOP1,NA,RASH(NTARG),0)
10061             CALL DT_CONUCL(COOT1,NB,RBSH(1),1)
10062             IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10063                CALL DT_CONUCL(COOP2,NA,RASH(NTARG),0)
10064                CALL DT_CONUCL(COOT2,NB,RBSH(1),1)
10065             ENDIF
10066          ENDIF
10067
10068 *  integration over impact parameter B
10069          DO 12 IB=1,NSITEB-1
10070             STOTB = ZERO
10071             SELAB = ZERO
10072             SQEPB = ZERO
10073             SQETB = ZERO
10074             SQE2B = ZERO
10075             SPROB = ZERO
10076             SDIR  = ZERO
10077             SDELB = ZERO
10078             SDQEB = ZERO
10079             B     = DBLE(IB)*BSTEP(NTARG)
10080             FACB  = 10.0D0*TWOPI*B*BSTEP(NTARG)
10081
10082 *   integration over M_V^2 for photon-proj.
10083             DO 14 IM=1,JPOINT
10084                PP11(1) = CONE
10085                PP12(1) = CONE
10086                PP21(1) = CONE
10087                PP22(1) = CONE
10088                IF (IJPROJ.EQ.7) THEN
10089                   DO 13 K=2,NB
10090                      PP11(K) = CONE
10091                      PP12(K) = CONE
10092                      PP21(K) = CONE
10093                      PP22(K) = CONE
10094    13             CONTINUE
10095                ENDIF
10096                SHI  = ZERO
10097                FACM = ONE
10098                DCOH = 1.0D10
10099
10100                IF (IJPROJ.EQ.7) THEN
10101                   AMV2 = EXP(ABSZX(IM))-Q2
10102                   AMV  = SQRT(AMV2)
10103                   IF (AMV2.LT.16.0D0) THEN
10104                      R = TWO
10105                   ELSEIF ((AMV2.GE.16.0D0).AND.(AMV2.LT.121.0D0)) THEN
10106                      R = 10.0D0/3.0D0
10107                   ELSE
10108                      R = 11.0D0/3.0D0
10109                   ENDIF
10110 *    define M_V dependent properties of nucleon scattering amplitude
10111 *     V_M-nucleon xsection
10112                   SIGMVD = RPNT*SIGSH/(AMV2+Q2+RL2)*10.0D0
10113                   SIGMV  = (ONE-RPNT)*SIGSH/(AMV2+Q2+RL2)
10114 *     slope-parametrisation a la Kaidalov
10115                   BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
10116      &                           +0.25D0*LOG(S/(AMV2+Q2)))
10117 *    coherence length
10118                   IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+Q2)*GEV2FM
10119 *    integration weight factor
10120                   FACM = ALPHEM/(3.0D0*PI*(ONE-X))*
10121      &                  R*AMV2/(AMV2+Q2)*(ONE+EPSPOL*Q2/AMV2)*WEIGHT(IM)
10122                ENDIF
10123                GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
10124                GAM = GSH
10125                IF (IJPROJ.EQ.7) THEN
10126                   RCA = GAM*SIGMV/TWOPI
10127                ELSE
10128                   RCA = GAM*SIGSH/TWOPI
10129                ENDIF
10130                FCA = -ROSH*RCA
10131                CA  = DCMPLX(RCA,FCA)
10132                CI  = CONE
10133
10134                DO 15 INA=1,NA
10135                   KK1  = 1
10136                   INT1 = 1
10137                   KK2  = 1
10138                   INT2 = 1
10139                   DO 16 INB=1,NB
10140 *    photon-projectile: check for supression by coherence length
10141                      IF (IJPROJ.EQ.7) THEN
10142                         IF (ABS(COOT1(3,INB)-COOT1(3,KK1)).GT.DCOH)THEN
10143                            KK1  = INB
10144                            INT1 = INT1+1
10145                         ENDIF
10146                         IF (ABS(COOT2(3,INB)-COOT2(3,KK2)).GT.DCOH)THEN
10147                            KK2  = INB
10148                            INT2 = INT2+1
10149                         ENDIF
10150                      ENDIF
10151
10152                      X11 = B+COOT1(1,INB)-COOP1(1,INA)
10153                      Y11 =   COOT1(2,INB)-COOP1(2,INA)
10154                      XY11 = GAM*(X11*X11+Y11*Y11)
10155                      IF (XY11.LE.15.0D0) THEN
10156                         C = CONE-CA*EXP(-XY11)
10157                         AR = DBLE(PP11(INT1))
10158                         AI = DIMAG(PP11(INT1))
10159                         IF (ABS(AR).LT.TINY25) AR = ZERO
10160                         IF (ABS(AI).LT.TINY25) AI = ZERO
10161                         PP11(INT1) = DCMPLX(AR,AI)
10162                         PP11(INT1) = PP11(INT1)*C
10163                         AR  = DBLE(C)
10164                         AI  = DIMAG(C)
10165                         SHI = SHI+LOG(AR*AR+AI*AI)
10166                      ENDIF
10167                      IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10168                         X12 = B+COOT2(1,INB)-COOP1(1,INA)
10169                         Y12 =   COOT2(2,INB)-COOP1(2,INA)
10170                         XY12 = GAM*(X12*X12+Y12*Y12)
10171                         IF (XY12.LE.15.0D0) THEN
10172                            C = CONE-CA*EXP(-XY12)
10173                            AR = DBLE(PP12(INT2))
10174                            AI = DIMAG(PP12(INT2))
10175                            IF (ABS(AR).LT.TINY25) AR = ZERO
10176                            IF (ABS(AI).LT.TINY25) AI = ZERO
10177                            PP12(INT2) = DCMPLX(AR,AI)
10178                            PP12(INT2) = PP12(INT2)*C
10179                         ENDIF
10180                         X21 = B+COOT1(1,INB)-COOP2(1,INA)
10181                         Y21 =   COOT1(2,INB)-COOP2(2,INA)
10182                         XY21 = GAM*(X21*X21+Y21*Y21)
10183                         IF (XY21.LE.15.0D0) THEN
10184                            C = CONE-CA*EXP(-XY21)
10185                            AR = DBLE(PP21(INT1))
10186                            AI = DIMAG(PP21(INT1))
10187                            IF (ABS(AR).LT.TINY25) AR = ZERO
10188                            IF (ABS(AI).LT.TINY25) AI = ZERO
10189                            PP21(INT1) = DCMPLX(AR,AI)
10190                            PP21(INT1) = PP21(INT1)*C
10191                         ENDIF
10192                         X22 = B+COOT2(1,INB)-COOP2(1,INA)
10193                         Y22 =   COOT2(2,INB)-COOP2(2,INA)
10194                         XY22 = GAM*(X22*X22+Y22*Y22)
10195                         IF (XY22.LE.15.0D0) THEN
10196                            C = CONE-CA*EXP(-XY22)
10197                            AR = DBLE(PP22(INT2))
10198                            AI = DIMAG(PP22(INT2))
10199                            IF (ABS(AR).LT.TINY25) AR = ZERO
10200                            IF (ABS(AI).LT.TINY25) AI = ZERO
10201                            PP22(INT2) = DCMPLX(AR,AI)
10202                            PP22(INT2) = PP22(INT2)*C
10203                         ENDIF
10204                      ENDIF
10205    16             CONTINUE
10206    15          CONTINUE
10207
10208                OMPP11 = CZERO
10209                OMPP21 = CZERO
10210                DIPP11 = CZERO
10211                DIPP21 = CZERO
10212                DO 17 K=1,INT1
10213                   IF (PP11(K).EQ.CZERO) THEN
10214                      PPTMP1 = CZERO
10215                      PPTMP2 = CZERO
10216                   ELSE
10217                      PPTMP1 = PP11(K)**(ONE-DIALPH-DIGAMM)
10218                      PPTMP2 = PP11(K)**(ONE-DIALPH+DIGAMM)
10219                   ENDIF
10220                   AVDIPP = 0.5D0*
10221      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10222                   OMPP11 = OMPP11+AVDIPP
10223 C                 OMPP11 = OMPP11+(CONE-PP11(K))
10224                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10225                   DIPP11 = DIPP11+AVDIPP
10226                   IF (PP21(K).EQ.CZERO) THEN
10227                      PPTMP1 = CZERO
10228                      PPTMP2 = CZERO
10229                   ELSE
10230                      PPTMP1 = PP21(K)**(ONE-DIALPH-DIGAMM)
10231                      PPTMP2 = PP21(K)**(ONE-DIALPH+DIGAMM)
10232                   ENDIF
10233                   AVDIPP = 0.5D0*
10234      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10235                   OMPP21 = OMPP21+AVDIPP
10236 C                 OMPP21 = OMPP21+(CONE-PP21(K))
10237                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10238                   DIPP21 = DIPP21+AVDIPP
10239    17          CONTINUE
10240                OMPP12 = CZERO
10241                OMPP22 = CZERO
10242                DIPP12 = CZERO
10243                DIPP22 = CZERO
10244                DO 18 K=1,INT2
10245                   IF (PP12(K).EQ.CZERO) THEN
10246                      PPTMP1 = CZERO
10247                      PPTMP2 = CZERO
10248                   ELSE
10249                      PPTMP1 = PP12(K)**(ONE-DIALPH-DIGAMM)
10250                      PPTMP2 = PP12(K)**(ONE-DIALPH+DIGAMM)
10251                   ENDIF
10252                   AVDIPP = 0.5D0*
10253      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10254                   OMPP12 = OMPP12+AVDIPP
10255 C                 OMPP12 = OMPP12+(CONE-PP12(K))
10256                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10257                   DIPP12 = DIPP12+AVDIPP
10258                   IF (PP22(K).EQ.CZERO) THEN
10259                      PPTMP1 = CZERO
10260                      PPTMP2 = CZERO
10261                   ELSE
10262                      PPTMP1 = PP22(K)**(ONE-DIALPH-DIGAMM)
10263                      PPTMP2 = PP22(K)**(ONE-DIALPH+DIGAMM)
10264                   ENDIF
10265                   AVDIPP = 0.5D0*
10266      &                  ( FACDI1*(CONE-PPTMP1)+FACDI2*(CONE-PPTMP2) )
10267                   OMPP22 = OMPP22+AVDIPP
10268 C                 OMPP22 = OMPP22+(CONE-PP22(K))
10269                   AVDIPP = 0.5D0*FACDI*( PPTMP1-PPTMP2 )
10270                   DIPP22 = DIPP22+AVDIPP
10271    18          CONTINUE
10272
10273                SPROM = ONE-EXP(SHI)
10274                SPROB = SPROB+FACM*SPROM
10275                IF ((.NOT.LPROD).OR.(IJPROJ.EQ.7)) THEN
10276                   STOTM = DBLE(OMPP11+OMPP22)
10277                   SELAM = DBLE(OMPP11*DCONJG(OMPP22))
10278                   SQEPM = DBLE(OMPP11*DCONJG(OMPP21))-SELAM
10279                   SQETM = DBLE(OMPP11*DCONJG(OMPP12))-SELAM
10280                   SQE2M = DBLE(OMPP11*DCONJG(OMPP11))-SELAM-SQEPM-SQETM
10281                   SDELM = DBLE(DIPP11*DCONJG(DIPP22))
10282                   SDQEM = DBLE(DIPP11*DCONJG(DIPP21))-SDELM
10283                   STOTB = STOTB+FACM*STOTM
10284                   SELAB = SELAB+FACM*SELAM
10285                   SDELB = SDELB+FACM*SDELM
10286                   IF (NB.GT.1) THEN
10287                      SQEPB = SQEPB+FACM*SQEPM
10288                      SDQEB = SDQEB+FACM*SDQEM
10289                   ENDIF
10290                   IF (NA.GT.1) SQETB = SQETB+FACM*SQETM
10291                   IF ((NA.GT.1).AND.(NB.GT.1)) SQE2B = SQE2B+FACM*SQE2M
10292                   IF (IJPROJ.EQ.7) SDIR = SDIR+FACM*SIGMVD
10293                ENDIF
10294
10295    14       CONTINUE
10296
10297             STOTN = STOTN+FACB*STOTB
10298             SELAN = SELAN+FACB*SELAB
10299             SQEPN = SQEPN+FACB*SQEPB
10300             SQETN = SQETN+FACB*SQETB
10301             SQE2N = SQE2N+FACB*SQE2B
10302             SPRON = SPRON+FACB*SPROB
10303             SDELN = SDELN+FACB*SDELB
10304             SDQEN = SDQEN+FACB*SDQEB
10305
10306             IF (IJPROJ.EQ.7) THEN
10307                BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*(STOTB-SELAB-SQEPB)
10308             ELSE
10309                IF (DIBETA.GT.ZERO) THEN
10310                   BPROD(IB+1)= BPROD(IB+1)
10311      &                        +FACN*FACB*(STOTB-SELAB-SQEPB-SQETB-SQE2B)
10312                ELSE
10313                   BPROD(IB+1)= BPROD(IB+1)+FACN*FACB*SPROB
10314                ENDIF
10315             ENDIF
10316
10317    12    CONTINUE
10318
10319          STOT  = STOT +FACN*STOTN
10320          STOT2 = STOT2+FACN*STOTN**2
10321          SELA  = SELA +FACN*SELAN
10322          SELA2 = SELA2+FACN*SELAN**2
10323          SQEP  = SQEP +FACN*SQEPN
10324          SQEP2 = SQEP2+FACN*SQEPN**2
10325          SQET  = SQET +FACN*SQETN
10326          SQET2 = SQET2+FACN*SQETN**2
10327          SQE2  = SQE2 +FACN*SQE2N
10328          SQE22 = SQE22+FACN*SQE2N**2
10329          SPRO  = SPRO +FACN*SPRON
10330          SPRO2 = SPRO2+FACN*SPRON**2
10331          SDEL  = SDEL +FACN*SDELN
10332          SDEL2 = SDEL2+FACN*SDELN**2
10333          SDQE  = SDQE +FACN*SDQEN
10334          SDQE2 = SDQE2+FACN*SDQEN**2
10335
10336    11 CONTINUE
10337
10338 * final cross sections
10339 * 1) total
10340       XSTOT(IE,IQ,NTARG) = STOT
10341       IF (IJPROJ.EQ.7)
10342      &   XSTOT(IE,IQ,NTARG) = XSTOT(IE,IQ,NTARG)+DBLE(NB)*SDIR
10343 * 2) elastic
10344       XSELA(IE,IQ,NTARG) = SELA
10345 * 3) quasi-el.: A+B-->A+X (excluding 2)
10346       XSQEP(IE,IQ,NTARG) = SQEP
10347 * 4) quasi-el.: A+B-->X+B (excluding 2)
10348       XSQET(IE,IQ,NTARG) = SQET
10349 * 5) quasi-el.: A+B-->X (excluding 2-4)
10350       XSQE2(IE,IQ,NTARG) = SQE2
10351 * 6) production (= STOT-SELA-SQEP-SQET-SQE2!)
10352       IF (SDEL.GT.ZERO) THEN
10353          XSPRO(IE,IQ,NTARG) = STOT-SELA-SQEP-SQET-SQE2
10354       ELSE
10355          XSPRO(IE,IQ,NTARG) = SPRO
10356       ENDIF
10357 * 7) projectile diffraction (el. scatt. off target)
10358       XSDEL(IE,IQ,NTARG) = SDEL
10359 * 8) projectile diffraction (quasi-el. scatt. off target)
10360       XSDQE(IE,IQ,NTARG) = SDQE
10361 *  stat. errors
10362       XETOT(IE,IQ,NTARG) = SQRT(ABS(STOT2-STOT**2)/DBLE(NSTATB-1))
10363       XEELA(IE,IQ,NTARG) = SQRT(ABS(SELA2-SELA**2)/DBLE(NSTATB-1))
10364       XEQEP(IE,IQ,NTARG) = SQRT(ABS(SQEP2-SQEP**2)/DBLE(NSTATB-1))
10365       XEQET(IE,IQ,NTARG) = SQRT(ABS(SQET2-SQET**2)/DBLE(NSTATB-1))
10366       XEQE2(IE,IQ,NTARG) = SQRT(ABS(SQE22-SQE2**2)/DBLE(NSTATB-1))
10367       XEPRO(IE,IQ,NTARG) = SQRT(ABS(SPRO2-SPRO**2)/DBLE(NSTATB-1))
10368       XEDEL(IE,IQ,NTARG) = SQRT(ABS(SDEL2-SDEL**2)/DBLE(NSTATB-1))
10369       XEDQE(IE,IQ,NTARG) = SQRT(ABS(SDQE2-SDQE**2)/DBLE(NSTATB-1))
10370
10371       IF (IJPROJ.EQ.7) THEN
10372          BNORM = XSTOT(IE,IQ,NTARG)-XSELA(IE,IQ,NTARG)
10373      &          -XSQEP(IE,IQ,NTARG)
10374       ELSE
10375          BNORM = XSPRO(IE,IQ,NTARG)
10376       ENDIF
10377       DO 19 I=2,NSITEB
10378          BSITE(IE,IQ,NTARG,I) = BPROD(I)/BNORM+BSITE(IE,IQ,NTARG,I-1)
10379          IF ((IE.EQ.1).AND.(IQ.EQ.1))
10380      &      BSITE(0,1,NTARG,I) = BPROD(I)/BNORM+BSITE(0,1,NTARG,I-1)
10381    19 CONTINUE
10382
10383 * write profile function data into file
10384       IF ((IOGLB.EQ.-1).OR.(IOGLB.EQ.-100)) THEN
10385          WRITE(LDAT,'(5I10,1P,E15.5)')
10386      &      IJPROJ,NA,NB,NSTATB,NSITEB,ECMNN(IE)
10387          WRITE(LDAT,'(1P,6E12.5)')
10388      &      XSTOT(IE,IQ,NTARG),XSELA(IE,IQ,NTARG),XSQEP(IE,IQ,NTARG),
10389      &      XSQET(IE,IQ,NTARG),XSQE2(IE,IQ,NTARG),XSPRO(IE,IQ,NTARG)
10390          WRITE(LDAT,'(1P,6E12.5)')
10391      &      XETOT(IE,IQ,NTARG),XEELA(IE,IQ,NTARG),XEQEP(IE,IQ,NTARG),
10392      &      XEQET(IE,IQ,NTARG),XEQE2(IE,IQ,NTARG),XEPRO(IE,IQ,NTARG)
10393          NLINES = INT(DBLE(NSITEB)/7.0D0)
10394          IF (NLINES.GT.0) THEN
10395             DO 20 I=1,NLINES
10396                ISTART = 7*I-6
10397                WRITE(LDAT,'(1P,7E11.4)')
10398      &            (BSITE(IE,IQ,NTARG,J),J=ISTART,ISTART+6)
10399    20       CONTINUE
10400          ENDIF
10401          ISTART = 7*NLINES+1
10402          IF (ISTART.LE.NSITEB) THEN
10403             WRITE(LDAT,'(1P,7E11.4)')
10404      &         (BSITE(IE,IQ,NTARG,J),J=ISTART,NSITEB)
10405          ENDIF
10406       ENDIF
10407
10408   100 CONTINUE
10409
10410 C     IF (ABS(IOGLB).EQ.1) CLOSE(LDAT)
10411
10412       RETURN
10413       END
10414
10415 *$ CREATE DT_GETBXS.FOR
10416 *COPY DT_GETBXS
10417 *
10418 *===getbxs=============================================================*
10419 *
10420       SUBROUTINE DT_GETBXS(XSFRAC,BLO,BHI,NIDX)
10421
10422 ************************************************************************
10423 * Biasing in impact parameter space.                                   *
10424 *     XSFRAC = 0 :  BLO    - minimum impact parameter  (input)         *
10425 *                   BHI    - maximum impact parameter  (input)         *
10426 *                   XSFRAC - fraction of cross section corresponding   *
10427 *                            to impact parameter range (BLO,BHI)       *
10428 *                                                      (output)        *
10429 *     XSFRAC > 0 :  XSFRAC - fraction of cross section (input)         *
10430 *                   BHI    - maximum impact parameter giving requested *
10431 *                            fraction of cross section in impact       *
10432 *                            parameter range (0,BMAX)  (output)        *
10433 * This version dated 17.03.00  is written by S. Roesler                *
10434 ************************************************************************
10435
10436       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10437       SAVE
10438
10439       PARAMETER ( LINP = 10 ,
10440      &            LOUT = 6 ,
10441      &            LDAT = 9 )
10442
10443       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10444
10445 * Glauber formalism: parameters
10446       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10447      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10448      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10449      &                NSITEB,NSTATB
10450
10451       NTARG = ABS(NIDX)
10452       IF (XSFRAC.LE.0.0D0) THEN
10453          ILO    = MIN(NSITEB-1,INT(BLO/BSTEP(NTARG)))
10454          IHI    = MIN(NSITEB-1,INT(BHI/BSTEP(NTARG)))
10455          IF (ILO.GE.IHI) THEN
10456             XSFRAC = 0.0D0
10457             RETURN
10458          ENDIF
10459          IF (ILO.EQ.NSITEB-1) THEN
10460             FRCLO = BSITE(0,1,NTARG,NSITEB)
10461          ELSE
10462             FRCLO = BSITE(0,1,NTARG,ILO+1)
10463      &              +(BLO-ILO*BSTEP(NTARG))/BSTEP(NTARG)
10464      &              *(BSITE(0,1,NTARG,ILO+2)-BSITE(0,1,NTARG,ILO+1))
10465          ENDIF
10466          IF (IHI.EQ.NSITEB-1) THEN
10467             FRCHI = BSITE(0,1,NTARG,NSITEB)
10468          ELSE
10469             FRCHI = BSITE(0,1,NTARG,IHI+1)
10470      &              +(BHI-IHI*BSTEP(NTARG))/BSTEP(NTARG)
10471      &              *(BSITE(0,1,NTARG,IHI+2)-BSITE(0,1,NTARG,IHI+1))
10472          ENDIF
10473          XSFRAC = FRCHI-FRCLO
10474       ELSE
10475          BLO = 0.0D0
10476          BHI = BMAX(NTARG)
10477          DO 1 I=1,NSITEB-1
10478             IF (XSFRAC.LT.BSITE(0,1,NTARG,I+1)) THEN
10479                FAC = (XSFRAC              -BSITE(0,1,NTARG,I))/
10480      &               (BSITE(0,1,NTARG,I+1)-BSITE(0,1,NTARG,I))
10481                BHI = DBLE(I-1)*BSTEP(NTARG)+BSTEP(NTARG)*FAC
10482                GOTO 2
10483             ENDIF
10484     1    CONTINUE
10485     2    CONTINUE
10486       ENDIF
10487
10488       RETURN
10489       END
10490
10491 *$ CREATE DT_CONUCL.FOR
10492 *COPY DT_CONUCL
10493 *
10494 *===conucl=============================================================*
10495 *
10496       SUBROUTINE DT_CONUCL(X,N,R,MODE)
10497
10498 ************************************************************************
10499 * Calculation of coordinates of nucleons within nuclei.                *
10500 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10501 *        N / R    number of nucleons / radius of nucleus   (input)     *
10502 *        MODE = 0 coordinates not sorted                               *
10503 *             = 1 coordinates sorted with increasing X(3,i)            *
10504 *             = 2 coordinates sorted with decreasing X(3,i)            *
10505 * This version dated 26.10.95 is revised by S. Roesler                 *
10506 ************************************************************************
10507
10508       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10509       SAVE
10510
10511       PARAMETER ( LINP = 10 ,
10512      &            LOUT = 6 ,
10513      &            LDAT = 9 )
10514
10515       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10516      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10517
10518       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10519
10520       PARAMETER (NSRT=10)
10521       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10522       DIMENSION X(3,N),XTMP(3,260)
10523
10524       CALL DT_COORDI(XTMP,IDXSRT,ICSRT,N,R)
10525
10526       IF ((MODE.NE.0).AND.(N.GT.4)) THEN
10527          K = 0
10528          DO 1 I=1,NSRT
10529             IF (MODE.EQ.2) THEN
10530                ISRT = NSRT+1-I
10531             ELSE
10532                ISRT = I
10533             ENDIF
10534             K1 = K
10535             DO 2 J=1,ICSRT(ISRT)
10536                K = K+1
10537                X(1,K) = XTMP(1,IDXSRT(ISRT,J))
10538                X(2,K) = XTMP(2,IDXSRT(ISRT,J))
10539                X(3,K) = XTMP(3,IDXSRT(ISRT,J))
10540     2       CONTINUE
10541             IF (ICSRT(ISRT).GT.1) THEN
10542                I0 = K1+1
10543                I1 = K
10544                CALL DT_SORT(X,N,I0,I1,MODE)
10545             ENDIF
10546     1    CONTINUE
10547       ELSEIF ((MODE.NE.0).AND.(N.GE.2).AND.(N.LE.4)) THEN
10548          DO 3 I=1,N
10549             X(1,I) = XTMP(1,I)
10550             X(2,I) = XTMP(2,I)
10551             X(3,I) = XTMP(3,I)
10552     3    CONTINUE
10553          CALL DT_SORT(X,N,1,N,MODE)
10554       ELSE
10555          DO 4 I=1,N
10556             X(1,I) = XTMP(1,I)
10557             X(2,I) = XTMP(2,I)
10558             X(3,I) = XTMP(3,I)
10559     4    CONTINUE
10560       ENDIF
10561
10562       RETURN
10563       END
10564
10565 *$ CREATE DT_COORDI.FOR
10566 *COPY DT_COORDI
10567 *
10568 *===coordi=============================================================*
10569 *
10570       SUBROUTINE DT_COORDI(X,IDXSRT,ICSRT,N,R)
10571
10572 ************************************************************************
10573 * Calculation of coordinates of nucleons within nuclei.                *
10574 *        X(3,N)   spatial coordinates of nucleons (in fm)  (output)    *
10575 *        N / R    number of nucleons / radius of nucleus   (input)     *
10576 * Based on the original version by Shmakov et al.                      *
10577 * This version dated 26.10.95 is revised by S. Roesler                 *
10578 ************************************************************************
10579
10580       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10581       SAVE
10582
10583       PARAMETER ( LINP = 10 ,
10584      &            LOUT = 6 ,
10585      &            LDAT = 9 )
10586
10587       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0,
10588      &           ONETHI=ONE/THREE,SQRTWO=1.414213562D0)
10589
10590       PARAMETER (TWOPI = 6.283185307179586454D+00 )
10591
10592       LOGICAL LSTART
10593
10594       PARAMETER (NSRT=10)
10595       DIMENSION IDXSRT(NSRT,200),ICSRT(NSRT)
10596       DIMENSION X(3,260),WD(4),RD(3)
10597
10598       DATA PDIF/0.545D0/,R2MIN/0.16D0/
10599       DATA WD / 0.0D0, 0.178D0, 0.465D0, 1.0D0/
10600       DATA RD /2.09D0, 0.935D0, 0.697D0/
10601
10602       X1SUM = ZERO
10603       X2SUM = ZERO
10604       X3SUM = ZERO
10605
10606       IF (N.EQ.1) THEN
10607          X(1,1) = ZERO
10608          X(2,1) = ZERO
10609          X(3,1) = ZERO
10610       ELSEIF (N.EQ.2) THEN
10611          EPS = DT_RNDM(RD(1))
10612          DO 30 I=1,3
10613             IF ((EPS.GE.WD(I)).AND.(EPS.LE.WD(I+1))) GOTO 40
10614    30    CONTINUE
10615    40    CONTINUE
10616          DO 50 J=1,3
10617             CALL DT_RANNOR(X1,X2)
10618             X(J,1) = RD(I)*X1
10619             X(J,2) = -X(J,1)
10620    50    CONTINUE
10621       ELSEIF ((N.EQ.3).OR.(N.EQ.4)) THEN
10622          SIGMA = R/SQRTWO
10623          LSTART = .TRUE.
10624          CALL DT_RANNOR(X3,X4)
10625          DO 100 I=1,N
10626             CALL DT_RANNOR(X1,X2)
10627             X(1,I) = SIGMA*X1
10628             X(2,I) = SIGMA*X2
10629             IF (LSTART) GOTO 80
10630             X(3,I) = SIGMA*X4
10631             CALL DT_RANNOR(X3,X4)
10632             GOTO 90
10633    80       CONTINUE
10634             X(3,I) = SIGMA*X3
10635    90       CONTINUE
10636             LSTART = .NOT.LSTART
10637             X1SUM = X1SUM+X(1,I)
10638             X2SUM = X2SUM+X(2,I)
10639             X3SUM = X3SUM+X(3,I)
10640   100    CONTINUE
10641          X1SUM = X1SUM/DBLE(N)
10642          X2SUM = X2SUM/DBLE(N)
10643          X3SUM = X3SUM/DBLE(N)
10644          DO 101 I=1,N
10645             X(1,I) = X(1,I)-X1SUM
10646             X(2,I) = X(2,I)-X2SUM
10647             X(3,I) = X(3,I)-X3SUM
10648   101    CONTINUE
10649       ELSE
10650
10651 * maximum nuclear radius for coordinate sampling
10652          RMAX = R+4.605D0*PDIF
10653
10654 * initialize pre-sorting
10655          DO 121 I=1,NSRT
10656             ICSRT(I) = 0
10657   121    CONTINUE
10658          DR = TWO*RMAX/DBLE(NSRT)
10659
10660 * sample coordinates for N nucleons
10661          DO 140 I=1,N
10662   120       CONTINUE
10663             RAD = RMAX*(DT_RNDM(DR))**ONETHI
10664             F   = DT_DENSIT(N,RAD,R)
10665             IF (DT_RNDM(RAD).GT.F) GOTO 120
10666 *   theta, phi uniformly distributed
10667             CT  = ONE-TWO*DT_RNDM(F)
10668             ST  = SQRT((ONE-CT)*(ONE+CT))
10669             CALL DT_DSFECF(SFE,CFE)
10670             X(1,I) = RAD*ST*CFE
10671             X(2,I) = RAD*ST*SFE
10672             X(3,I) = RAD*CT
10673 *   ensure that distance between two nucleons is greater than R2MIN
10674             IF (I.LT.2) GOTO 122
10675             I1 = I-1
10676             DO 130 I2=1,I1
10677                DIST2 = (X(1,I)-X(1,I2))**2+(X(2,I)-X(2,I2))**2+
10678      &                 (X(3,I)-X(3,I2))**2
10679                IF (DIST2.LE.R2MIN) GOTO 120
10680   130       CONTINUE
10681   122       CONTINUE
10682 *   save index according to z-bin
10683             IDXZ        = INT( (X(3,I)+RMAX)/DR )+1
10684             ICSRT(IDXZ) = ICSRT(IDXZ)+1
10685             IDXSRT(IDXZ,ICSRT(IDXZ)) = I
10686             X1SUM = X1SUM+X(1,I)
10687             X2SUM = X2SUM+X(2,I)
10688             X3SUM = X3SUM+X(3,I)
10689   140    CONTINUE
10690          X1SUM = X1SUM/DBLE(N)
10691          X2SUM = X2SUM/DBLE(N)
10692          X3SUM = X3SUM/DBLE(N)
10693          DO 141 I=1,N
10694             X(1,I) = X(1,I)-X1SUM
10695             X(2,I) = X(2,I)-X2SUM
10696             X(3,I) = X(3,I)-X3SUM
10697   141    CONTINUE
10698
10699       ENDIF
10700
10701       RETURN
10702       END
10703
10704 *$ CREATE DT_DENSIT.FOR
10705 *COPY DT_DENSIT
10706 *
10707 *===densit=============================================================*
10708 *
10709       DOUBLE PRECISION FUNCTION DT_DENSIT(NA,R,RA)
10710
10711       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10712       SAVE
10713
10714       PARAMETER ( LINP = 10 ,
10715      &            LOUT = 6 ,
10716      &            LDAT = 9 )
10717
10718       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
10719       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
10720      &           PI    = TWOPI/TWO)
10721
10722       DIMENSION R0(18),FNORM(18)
10723       DATA R0 /  ZERO,   ZERO,   ZERO,   ZERO, 2.12D0,
10724      &         2.56D0, 2.41D0, 2.46D0, 2.52D0, 2.45D0,
10725      &         2.37D0, 2.46D0, 2.44D0, 2.54D0, 2.58D0,
10726      &         2.72D0, 2.66D0, 2.79D0/
10727       DATA FNORM /.1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10728      &            .1000D+01,.1000D+01,.1000D+01,.1000D+01,.1000D+01,
10729      &            .1012D+01,.1039D+01,.1075D+01,.1118D+01,.1164D+01,
10730      &            .1214D+01,.1265D+01,.1318D+01/
10731       DATA PDIF /0.545D0/
10732
10733       DT_DENSIT = ZERO
10734 * shell model
10735       IF (NA.LE.4) THEN
10736          STOP 'DT_DENSIT-0'
10737       ELSEIF ((NA.GT.4).AND.(NA.LE.18)) THEN
10738          R1 = R0(NA)/SQRT(2.5D0-4.0D0/DBLE(NA))
10739          DT_DENSIT = (ONE+(DBLE(NA)-4.0D0)/6.0D0*(R/R1)**2)
10740      &            *EXP(-(R/R1)**2)/FNORM(NA)
10741 * Woods-Saxon
10742       ELSEIF (NA.GT.18) THEN
10743          DT_DENSIT = ONE/(ONE+EXP((R-RA)/PDIF))
10744       ENDIF
10745
10746       RETURN
10747       END
10748
10749 *$ CREATE DT_RNCLUS.FOR
10750 *COPY DT_RNCLUS
10751 *
10752 *===rnclus=============================================================*
10753 *
10754       DOUBLE PRECISION FUNCTION DT_RNCLUS(N)
10755
10756 ************************************************************************
10757 * Nuclear radius for nucleus with mass number N.                       *
10758 * This version dated 26.9.00  is written by S. Roesler                 *
10759 ************************************************************************
10760
10761       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10762       SAVE
10763
10764       PARAMETER (ONE=1.0D0,THREE=3.0D0,ONETHI=ONE/THREE)
10765
10766 * nucleon radius
10767       PARAMETER (RNUCLE = 1.12D0)
10768
10769 * nuclear radii for selected nuclei
10770       DIMENSION RADNUC(18)
10771       DATA RADNUC / 8*0.0D0,2.52D0,2.45D0,2.37D0,2.45D0,2.44D0,2.55D0,
10772      &               2.58D0,2.71D0,2.66D0,2.71D0/
10773
10774       IF (N.LE.18) THEN
10775          IF (RADNUC(N).GT.0.0D0) THEN
10776             DT_RNCLUS = RADNUC(N)
10777          ELSE
10778             DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10779          ENDIF
10780       ELSE
10781          DT_RNCLUS = RNUCLE*DBLE(N)**ONETHI
10782       ENDIF
10783
10784       RETURN
10785       END
10786
10787 *$ CREATE DT_DENTST.FOR
10788 *COPY DT_DENTST
10789 *
10790 *===dentst=============================================================*
10791 *
10792 C      PROGRAM DT_DENTST
10793       SUBROUTINE DT_DENTST
10794
10795       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10796       SAVE
10797
10798       OPEN(40,FILE='dentst.out',STATUS='UNKNOWN')
10799       OPEN(41,FILE='denmax.out',STATUS='UNKNOWN')
10800
10801       RMIN  = 0.0D0
10802       RMAX  = 8.0D0
10803       NBINS = 500.0D0
10804       DR    = (RMAX-RMIN)/DBLE(NBINS)
10805       DO 1 IA=5,18
10806          FMAX = 0.0D0
10807          DO 2 IR=1,NBINS+1
10808             R = RMIN+DBLE(IR-1)*DR
10809             F = DT_DENSIT(IA,R,R)
10810             IF (F.GT.FMAX) FMAX = F
10811             WRITE(40,'(1X,I3,2E15.5)') IA,R,F
10812     2    CONTINUE
10813          WRITE(41,'(1X,I3,E15.5)') IA,FMAX
10814     1 CONTINUE
10815
10816       CLOSE(40)
10817       CLOSE(41)
10818
10819       END
10820
10821 *$ CREATE DT_SHMAKI.FOR
10822 *COPY DT_SHMAKI
10823 *
10824 *===shmaki=============================================================*
10825 *
10826       SUBROUTINE DT_SHMAKI(NA,NCA,NB,NCB,IJP,PPN,MODE)
10827
10828 ************************************************************************
10829 * Initialisation of Glauber formalism. This subroutine has to be       *
10830 * called once (in case of target emulsions as often as many different  *
10831 * target nuclei are considered) before events are sampled.             *
10832 *         NA / NCA   mass number/charge of projectile nucleus          *
10833 *         NB / NCB   mass number/charge of target     nucleus          *
10834 *         IJP        identity of projectile (hadrons/leptons/photons)  *
10835 *         PPN        projectile momentum (for projectile nuclei:       *
10836 *                    momentum per nucleon) in target rest system       *
10837 *         MODE = 0   Glauber formalism invoked                         *
10838 *              = 1   fitted results are loaded from data-file          *
10839 *              = 99  NTARG is forced to be 1                           *
10840 *                    (used in connection with GLAUBERI-card only)      *
10841 * This version dated 22.03.96 is based on the original SHMAKI-routine  *
10842 * and revised by S. Roesler.                                           *
10843 ************************************************************************
10844
10845       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
10846       SAVE
10847
10848       PARAMETER ( LINP = 10 ,
10849      &            LOUT = 6 ,
10850      &            LDAT = 9 )
10851
10852       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
10853      &           THREE=3.0D0)
10854
10855       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
10856
10857 * Glauber formalism: parameters
10858       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
10859      &                BMAX(NCOMPX),BSTEP(NCOMPX),
10860      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
10861      &                NSITEB,NSTATB
10862
10863 * Lorentz-parameters of the current interaction
10864       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
10865      &                UMO,PPCM,EPROJ,PPROJ
10866
10867 * properties of photon/lepton projectiles
10868       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
10869
10870 * kinematical cuts for lepton-nucleus interactions
10871       COMMON /DTLCUT/ ECMIN,ECMAX,XBJMIN,ELMIN,EGMIN,EGMAX,YMIN,YMAX,
10872      &                Q2MIN,Q2MAX,THMIN,THMAX,Q2LI,Q2HI,ECMLI,ECMHI
10873
10874 * Glauber formalism: cross sections
10875       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
10876      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
10877      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
10878      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
10879      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
10880      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
10881      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
10882      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
10883      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
10884      &                BSLOPE,NEBINI,NQBINI
10885
10886 * cuts for variable energy runs
10887       COMMON /DTVARE/ VARELO,VAREHI,VARCLO,VARCHI
10888
10889 * nucleon-nucleon event-generator
10890       CHARACTER*8 CMODEL
10891       LOGICAL LPHOIN
10892       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
10893
10894 * Glauber formalism: flags and parameters for statistics
10895       LOGICAL LPROD
10896       CHARACTER*8 CGLB
10897       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
10898
10899       DATA NTARG,ICOUT,IVEOUT /0,0,0/
10900
10901 C     CALL DT_HISHAD
10902 C     STOP
10903
10904       NTARG = NTARG+1
10905       IF (MODE.EQ.99) NTARG = 1
10906       NIDX = -NTARG
10907       IF (MODE.EQ.-1) NIDX = NTARG
10908
10909       IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) ICOUT = ICOUT+1
10910       IF (ICOUT.EQ.1) WRITE(LOUT,1000)
10911  1000    FORMAT(//,1X,'SHMAKI:    Glauber formalism (Shmakov et. al) -',
10912      &          ' initialization',/,12X,'--------------------------',
10913      &          '-------------------------',/)
10914
10915       IF (MODE.EQ.2) THEN
10916          CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
10917          CALL DT_SHFAST(MODE,PPN,IBACK)
10918          STOP ' Glauber pre-initialization done'
10919       ENDIF
10920       IF (MODE.EQ.1) THEN
10921          CALL DT_PROFBI(NA,NB,PPN,NTARG)
10922       ELSE
10923          IBACK = 1
10924          IF (MODE.EQ.3)  CALL DT_SHFAST(MODE,PPN,IBACK)
10925          IF (IBACK.EQ.1) THEN
10926 * lepton-nucleus (variable energy runs)
10927             IF ((IJP.EQ. 3).OR.(IJP.EQ. 4).OR.
10928      &          (IJP.EQ.10).OR.(IJP.EQ.11))   THEN
10929                IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10930      &            WRITE(LOUT,1002) NB,NCB
10931  1002          FORMAT(1X,'variable energy run:     projectile-id:  7',
10932      &                '    target A/Z: ',I3,' /',I3,/,/,8X,
10933      &                'E_cm (GeV)    Q^2 (GeV^2)',
10934      &                '    Sigma_tot (mb)     Sigma_in (mb)',/,7X,
10935      &                '--------------------------------',
10936      &                '------------------------------')
10937                AECMLO = LOG10(MIN(UMO,ECMLI))
10938                AECMHI = LOG10(MIN(UMO,ECMHI))
10939                IESTEP = NEB-1
10940                DAECM  = (AECMHI-AECMLO)/DBLE(IESTEP)
10941                IF (AECMLO.EQ.AECMHI) IESTEP = 0
10942                DO 1 I=1,IESTEP+1
10943                   ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10944                   IF (Q2HI.GT.0.1D0) THEN
10945                      IF (Q2LI.LT.0.01D0) THEN
10946                         CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10947                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10948      &                     WRITE(LOUT,1003)
10949      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10950                         Q2LI = 0.01D0
10951                         IBIN = 2
10952                      ELSE
10953                         IBIN = 1
10954                      ENDIF
10955                      IQSTEP = NQB-IBIN
10956                      AQ2LO  = LOG10(Q2LI)
10957                      AQ2HI  = LOG10(Q2HI)
10958                      DAQ2   = (AQ2HI-AQ2LO)/MAX(DBLE(IQSTEP),ONE)
10959                      DO 2 J=IBIN,IQSTEP+IBIN
10960                         Q2 = 10.0D0**(AQ2LO+DBLE(J-IBIN)*DAQ2)
10961                         CALL DT_XSGLAU(NA,NB,7,ZERO,Q2,ECM,I,J,NIDX)
10962                         IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10963      &                     WRITE(LOUT,1003) ECMNN(I),
10964      &                     Q2G(J),XSTOT(I,J,NTARG),XSPRO(I,J,NTARG)
10965     2                CONTINUE
10966                   ELSE
10967                      CALL DT_XSGLAU(NA,NB,7,ZERO,ZERO,ECM,I,1,NIDX)
10968                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
10969      &                  WRITE(LOUT,1003)
10970      &                  ECMNN(I),ZERO,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
10971                   ENDIF
10972  1003             FORMAT(9X,F6.1,9X,F6.2,8X,F8.3,11X,F8.3)
10973     1          CONTINUE
10974                IVEOUT = 1
10975             ELSE
10976 * hadron/photon/nucleus-nucleus
10977                IF ((ABS(VAREHI).GT.ZERO).AND.
10978      &             (ABS(VAREHI).GT.ABS(VARELO))) THEN
10979                   IF ((ICOUT.LT.15).AND.(MCGENE.NE.4)) THEN
10980                      WRITE(LOUT,1004) NA,NB,NCB
10981  1004                FORMAT(1X,'variable energy run:    projectile-id:',
10982      &                      I3,'    target A/Z: ',I3,' /',I3,/)
10983                      WRITE(LOUT,1005)
10984  1005                FORMAT('  E_cm (GeV)  E_Lab (GeV)  sig_tot^pp (mb)'
10985      &                      ,'  Sigma_tot (mb)  Sigma_prod (mb)',/,
10986      &                      ' -------------------------------------',
10987      &                      '--------------------------------------')
10988                   ENDIF
10989                   AECMLO = LOG10(VARCLO)
10990                   AECMHI = LOG10(VARCHI)
10991                   IESTEP = NEB-1
10992                   DAECM = (AECMHI-AECMLO)/DBLE(IESTEP)
10993                   IF (AECMLO.EQ.AECMHI) IESTEP = 0
10994                   DO 3 I=1,IESTEP+1
10995                      ECM = 10.0D0**(AECMLO+DBLE(I-1)*DAECM)
10996                      AMP = 0.938D0
10997                      AMT = 0.938D0
10998                      AMP2 = AMP**2
10999                      AMT2 = AMT**2
11000                      ELAB = (ECM**2-AMP2-AMT2)/(TWO*AMT)
11001                      PLAB = SQRT((ELAB+AMP)*(ELAB-AMP))
11002                      CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,ECM,I,1,NIDX)
11003                      IF ((ICOUT.LT.15).AND.(MCGENE.NE.4))
11004      &                 WRITE(LOUT,1006)
11005      &                 ECM,PLAB,SIGSH,XSTOT(I,1,NTARG),XSPRO(I,1,NTARG)
11006  1006             FORMAT(1X,F9.1,1X,E11.3,1X,F12.2,8X,F10.3,8X,F8.3)
11007     3             CONTINUE
11008                   IVEOUT = 1
11009                ELSE
11010                   CALL DT_XSGLAU(NA,NB,IJP,ZERO,VIRT,UMO,1,1,NIDX)
11011                ENDIF
11012             ENDIF
11013          ENDIF
11014       ENDIF
11015
11016       IF ((ICOUT.LT.15).AND.(IVEOUT.EQ.0).AND.(MCGENE.NE.4).AND.
11017      &    (IOGLB.NE.100)) THEN
11018          WRITE(LOUT,1001) NA,NCA,NB,NCB,ECMNN(1),SIGSH*10.0D0,ROSH,
11019      &                    BSLOPE,NSITEB,NSTATB,XSPRO(1,1,NTARG)
11020  1001    FORMAT(38X,'projectile',
11021      &          '      target',/,1X,'Mass number / charge',
11022      &          17X,I3,' /',I3,6X,I3,' /',I3,/,/,1X,
11023      &          'Nucleon-nucleon c.m. energy',9X,F10.2,' GeV',/,/,1X,
11024      &          'Parameters of elastic scattering amplitude:',/,5X,
11025      &          'sigma =',F7.2,' mb',6X,'rho = ',F9.4,6X,'slope = ',
11026      &          F4.1,' GeV^-2',/,/,1X,'Number of b-steps',4X,I3,8X,
11027      &          'statistics at each b-step',4X,I5,/,/,1X,
11028      &          'Prod. cross section  ',5X,F10.4,' mb',/)
11029       ENDIF
11030
11031       RETURN
11032       END
11033
11034 *$ CREATE DT_PROFBI.FOR
11035 *COPY DT_PROFBI
11036 *
11037 *===profbi=============================================================*
11038 *
11039       SUBROUTINE DT_PROFBI(NA,NB,PPN,NTARG)
11040
11041 ************************************************************************
11042 * Integral over profile function (to be used for impact-parameter      *
11043 * sampling during event generation).                                   *
11044 * Fitted results are used.                                             *
11045 *         NA / NB    mass numbers of proj./target nuclei               *
11046 *         PPN        projectile momentum (for projectile nuclei:       *
11047 *                    momentum per nucleon) in target rest system       *
11048 *         NTARG      index of target material (i.e. kind of nucleus)   *
11049 * This version dated 31.05.95 is revised by S. Roesler                 *
11050 ************************************************************************
11051
11052       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11053       SAVE
11054
11055       PARAMETER ( LINP = 10 ,
11056      &            LOUT = 6 ,
11057      &            LDAT = 9 )
11058
11059       SAVE
11060
11061       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,THREE=3.0D0)
11062
11063       LOGICAL LSTART
11064       CHARACTER CNAME*80
11065
11066       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11067
11068 * Glauber formalism: parameters
11069       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11070      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11071      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11072      &                NSITEB,NSTATB
11073
11074 * Glauber formalism: cross sections
11075       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11076      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11077      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11078      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11079      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11080      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11081      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11082      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11083      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11084      &                BSLOPE,NEBINI,NQBINI
11085
11086       PARAMETER (NGLMAX=8000)
11087       DIMENSION NGLIT(NGLMAX),NGLIP(NGLMAX),GLAPPN(NGLMAX),
11088      &          GLASIG(NGLMAX),GLAFIT(5,NGLMAX)
11089
11090       DATA LSTART /.TRUE./
11091
11092       IF (LSTART) THEN
11093 * read fit-parameters from file
11094          OPEN(47,FILE='inpdata/glpara.dat',STATUS='UNKNOWN')
11095          I = 0
11096     1    CONTINUE
11097          READ(47,'(A80)') CNAME
11098          IF (CNAME.EQ.'STOP') GOTO 2
11099          I = I+1
11100          READ(CNAME,*) NGLIP(I),NGLIT(I),GLAPPN(I),GLASIG(I),
11101      &                 GLAFIT(1,I),GLAFIT(2,I),GLAFIT(3,I),
11102      &                 GLAFIT(4,I),GLAFIT(5,I)
11103          IF (I+1.GT.NGLMAX) THEN
11104             WRITE(LOUT,1000)
11105  1000       FORMAT(1X,'PROFBI:    warning! array size exceeded - ',
11106      &             'program stopped')
11107             STOP
11108          ENDIF
11109          GOTO 1
11110     2    CONTINUE
11111          NGLPAR = I
11112          LSTART = .FALSE.
11113       ENDIF
11114
11115       NNA = NA
11116       NNB = NB
11117       IF (NA.GT.NB) THEN
11118          NNA = NB
11119          NNB = NA
11120       ENDIF
11121       IDXGLA = 0
11122       DO 3 J=1,NGLPAR
11123          IF ((NNB.LT.NGLIT(J)).OR.(J.EQ.NGLPAR)) THEN
11124             IF (NNB.NE.NGLIT(J-1)) NNB = NGLIT(J-1)
11125             DO 4 K=1,J-1
11126                IPOINT = J-K
11127                IF (J.EQ.NGLPAR) IPOINT = J+1-K
11128                IF ((NNA.GT.NGLIP(IPOINT)).OR.
11129      &             (NNB.NE.NGLIT(IPOINT)).OR.(IPOINT.EQ.1)) THEN
11130                   IF (IPOINT.EQ.1) IPOINT = 0
11131                   NATMP = NGLIP(IPOINT+1)
11132                   IF (PPN.LT.GLAPPN(IPOINT+1)) THEN
11133                      IDXGLA = IPOINT+1
11134                      GOTO 6
11135                   ELSE
11136                      J1BEG = IPOINT+1
11137                      J1END = J
11138 C                    IF (J.EQ.NGLPAR) THEN
11139 C                       J1BEG = IPOINT
11140 C                       J1END = J
11141 C                    ENDIF
11142                      DO 5 J1=J1BEG,J1END
11143                         IF (NGLIP(J1).EQ.NATMP) THEN
11144                            IF (PPN.LT.GLAPPN(J1)) THEN
11145                               IDXGLA = J1
11146                               GOTO 6
11147                            ENDIF
11148                         ELSE
11149                            IDXGLA = J1-1
11150                            GOTO 6
11151                         ENDIF
11152     5                CONTINUE
11153                      IF ((J.EQ.NGLPAR).AND.(PPN.GT.GLAPPN(NGLPAR)))
11154      &                  IDXGLA = NGLPAR
11155                   ENDIF
11156                ENDIF
11157     4       CONTINUE
11158          ENDIF
11159     3 CONTINUE
11160
11161     6 CONTINUE
11162       IF (IDXGLA.EQ.0) THEN
11163          WRITE(LOUT,1001) NNA,NNB,PPN
11164  1001    FORMAT(1X,'PROFBI:   configuration (NA,NB,PPN = ',
11165      &          2I4,F6.0,') not found ')
11166          STOP
11167       ENDIF
11168
11169 * no interpolation yet available
11170       XSPRO(1,1,NTARG) = GLASIG(IDXGLA)
11171
11172       BSITE(1,1,NTARG,1) = ZERO
11173       DO 10 I=2,NSITEB
11174          XX = DBLE(I)
11175          POLY  = GLAFIT(1,IDXGLA)+GLAFIT(2,IDXGLA)*XX+
11176      &           GLAFIT(3,IDXGLA)*XX**2+GLAFIT(4,IDXGLA)*XX**3+
11177      &           GLAFIT(5,IDXGLA)*XX**4
11178          IF (ABS(POLY).GT.35.0D0) POLY = SIGN(35.0D0,POLY)
11179          BSITE(1,1,NTARG,I) = (1.0D0-EXP(-POLY))
11180          IF (BSITE(1,1,NTARG,I).LT.ZERO) BSITE(1,1,NTARG,I) = ZERO
11181    10 CONTINUE
11182
11183       RETURN
11184       END
11185
11186 *$ CREATE DT_GLAUBE.FOR
11187 *COPY DT_GLAUBE
11188 *
11189 *===glaube=============================================================*
11190 *
11191       SUBROUTINE DT_GLAUBE(NA,NB,IJPROJ,B,INTT,INTA,INTB,JS,JT,NIDX)
11192
11193 ************************************************************************
11194 * Calculation of configuartion of interacting nucleons for one event.  *
11195 *    NB / NB    mass numbers of proj./target nuclei           (input)  *
11196 *    B          impact parameter                              (output) *
11197 *    INTT       total number of wounded nucleons                 "     *
11198 *    INTA / INTB number of wounded nucleons in proj. / target    "     *
11199 *    JS / JT(i) number of collisions proj. / target nucleon i is       *
11200 *                                                   involved  (output) *
11201 *    NIDX       index of projectile/target material            (input) *
11202 *               = -2 call within FLUKA transport calculation           *
11203 * This is an update of the original routine SHMAKO by J.Ranft/HJM      *
11204 * This version dated 22.03.96 is revised by S. Roesler                 *
11205 *                                                                      *
11206 * Last change 27.12.2006 by S. Roesler.                                *
11207 ************************************************************************
11208
11209       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11210       SAVE
11211
11212       PARAMETER ( LINP = 10 ,
11213      &            LOUT = 6 ,
11214      &            LDAT = 9 )
11215
11216       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
11217      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
11218
11219       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11220
11221       PARAMETER ( MAXNCL = 260,
11222
11223      &            MAXVQU = MAXNCL,
11224      &            MAXSQU = 20*MAXVQU,
11225      &            MAXINT = MAXVQU+MAXSQU)
11226
11227 * Glauber formalism: parameters
11228       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11229      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11230      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11231      &                NSITEB,NSTATB
11232
11233 * Glauber formalism: cross sections
11234       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11235      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11236      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11237      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11238      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11239      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11240      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11241      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11242      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11243      &                BSLOPE,NEBINI,NQBINI
11244
11245 * Lorentz-parameters of the current interaction
11246       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
11247      &                UMO,PPCM,EPROJ,PPROJ
11248
11249 * properties of photon/lepton projectiles
11250       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
11251
11252 * Glauber formalism: collision properties
11253       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
11254      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
11255
11256 * Glauber formalism: flags and parameters for statistics
11257       LOGICAL LPROD
11258       CHARACTER*8 CGLB
11259       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
11260
11261       DIMENSION JS(MAXNCL),JT(MAXNCL)
11262
11263       NTARG = ABS(NIDX)
11264
11265 * get actual energy from /DTLTRA/
11266       ECMNOW = UMO
11267       Q2     = VIRT
11268 *
11269 * new patch for pre-initialized variable projectile/target/energy runs,
11270 * bypassed for use within FLUKA (Nidx=-2)
11271       IF (IOGLB.EQ.100) THEN
11272          IF (NIDX.NE.-2) CALL DT_GLBSET(IJPROJ,NA,NB,EPROJ,1)
11273 *
11274 * variable energy run, interpolate profile function
11275       ELSE
11276          I1   = 1
11277          I2   = 1
11278          RATE = ONE
11279          IF (NEBINI.GT.1) THEN
11280             IF (ECMNOW.GE.ECMNN(NEBINI)) THEN
11281                I1   = NEBINI
11282                I2   = NEBINI
11283                RATE = ONE
11284             ELSEIF (ECMNOW.GT.ECMNN(1)) THEN
11285                DO 1 I=2,NEBINI
11286                   IF (ECMNOW.LT.ECMNN(I)) THEN
11287                      I1   = I-1
11288                      I2   = I
11289                      RATE = (ECMNOW-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
11290                      GOTO 2
11291                   ENDIF
11292     1          CONTINUE
11293     2          CONTINUE
11294             ENDIF
11295          ENDIF
11296          J1   = 1
11297          J2   = 1
11298          RATQ = ONE
11299          IF (NQBINI.GT.1) THEN
11300             IF (Q2.GE.Q2G(NQBINI)) THEN
11301                J1   = NQBINI
11302                J2   = NQBINI
11303                RATQ = ONE
11304             ELSEIF (Q2.GT.Q2G(1)) THEN
11305                DO 3 I=2,NQBINI
11306                   IF (Q2.LT.Q2G(I)) THEN
11307                      J1   = I-1
11308                      J2   = I
11309                      RATQ = LOG10(     Q2/MAX(Q2G(J1),TINY14))/
11310      &                      LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
11311 C                    RATQ = (Q2-Q2G(J1))/(Q2G(J2)-Q2G(J1))
11312                      GOTO 4
11313                   ENDIF
11314     3          CONTINUE
11315     4          CONTINUE
11316             ENDIF
11317          ENDIF
11318
11319          DO 5 I=1,KSITEB
11320             BSITE(0,1,NTARG,I) = BSITE(I1,J1,NTARG,I)+
11321      &         RATE*(BSITE(I2,J1,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11322      &         RATQ*(BSITE(I1,J2,NTARG,I)-BSITE(I1,J1,NTARG,I))+
11323      &         RATE*RATQ*(BSITE(I2,J2,NTARG,I)-BSITE(I1,J2,NTARG,I)+
11324      &                    BSITE(I1,J1,NTARG,I)-BSITE(I2,J1,NTARG,I))
11325     5    CONTINUE
11326       ENDIF
11327
11328       CALL DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,INTT,INTA,INTB,IDIREC,NIDX)
11329       IF (NIDX.LE.-1) THEN
11330          RPROJ = RASH(1)
11331          RTARG = RBSH(NTARG)
11332       ELSE
11333          RPROJ = RASH(NTARG)
11334          RTARG = RBSH(1)
11335       ENDIF
11336
11337       RETURN
11338       END
11339
11340 *$ CREATE DT_DIAGR.FOR
11341 *COPY DT_DIAGR
11342 *
11343 *===diagr==============================================================*
11344 *
11345       SUBROUTINE DT_DIAGR(NA,NB,IJPROJ,B,JS,JT,JNT,INTA,INTB,IDIREC,
11346      &                                                         NIDX)
11347
11348 ************************************************************************
11349 * Based on the original version by Shmakov et al.                      *
11350 * This version dated 21.04.95 is revised by S. Roesler                 *
11351 ************************************************************************
11352
11353       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11354       SAVE
11355
11356       PARAMETER ( LINP = 10 ,
11357      &            LOUT = 6 ,
11358      &            LDAT = 9 )
11359
11360       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
11361       PARAMETER (TWOPI  = 6.283185307179586454D+00,
11362      &           PI     = TWOPI/TWO,
11363      &           GEV2MB = 0.38938D0,
11364      &           GEV2FM = 0.1972D0,
11365      &           ALPHEM = ONE/137.0D0,
11366 * proton mass
11367      &           AMP    = 0.938D0,
11368      &           AMP2   = AMP**2,
11369 * rho0 mass
11370      &           AMRHO0 = 0.77D0)
11371
11372       COMPLEX*16 C,CA,CI
11373
11374       PARAMETER ( MAXNCL = 260,
11375
11376      &            MAXVQU = MAXNCL,
11377      &            MAXSQU = 20*MAXVQU,
11378      &            MAXINT = MAXVQU+MAXSQU)
11379
11380 * particle properties (BAMJET index convention)
11381       CHARACTER*8  ANAME
11382       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
11383      &                IICH(210),IIBAR(210),K1(210),K2(210)
11384
11385       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11386
11387 * emulsion treatment
11388       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
11389      &                NCOMPO,IEMUL
11390
11391 * Glauber formalism: parameters
11392       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11393      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11394      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11395      &                NSITEB,NSTATB
11396
11397 * Glauber formalism: cross sections
11398       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11399      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11400      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11401      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11402      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11403      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11404      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11405      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11406      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11407      &                BSLOPE,NEBINI,NQBINI
11408
11409 * VDM parameter for photon-nucleus interactions
11410       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11411
11412 * nucleon-nucleon event-generator
11413       CHARACTER*8 CMODEL
11414       LOGICAL LPHOIN
11415       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
11416 **PHOJET105a
11417 C     COMMON /CUTOFF/ PTCUT(4),CUTMU(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11418 **PHOJET112
11419
11420 C  obsolete cut-off information
11421       DOUBLE PRECISION PTCUT,PTANO,FPS,FPH,PSOMIN,XSOMIN
11422       COMMON /POCUT1/ PTCUT(4),PTANO(4),FPS(4),FPH(4),PSOMIN,XSOMIN
11423 **
11424
11425 * coordinates of nucleons
11426       COMMON /DTNUCO/ PKOO(3,MAXNCL),TKOO(3,MAXNCL)
11427
11428 * interface between Glauber formalism and DPM
11429       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
11430      &                INTER1(MAXINT),INTER2(MAXINT)
11431
11432 * statistics: Glauber-formalism
11433       COMMON /DTSTA3/ ICWP,ICWT,NCSY,ICWPG,ICWTG,ICIG,IPGLB,ITGLB,NGLB
11434
11435 * n-n cross section fluctuations
11436       PARAMETER (NBINS = 1000)
11437       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
11438
11439       DIMENSION JS(MAXNCL),JT(MAXNCL),
11440      &          JS0(MAXNCL),JT0(MAXNCL,MAXNCL),
11441      &          JI1(MAXNCL,MAXNCL),JI2(MAXNCL,MAXNCL),JNT0(MAXNCL)
11442       DIMENSION NWA(0:210),NWB(0:210)
11443
11444       LOGICAL LFIRST
11445       DATA LFIRST /.TRUE./
11446
11447       DATA NTARGO,ICNT /0,0/
11448
11449       NTARG = ABS(NIDX)
11450
11451       IF (LFIRST) THEN
11452          LFIRST = .FALSE.
11453          IF (NCOMPO.EQ.0) THEN
11454             NCALL  = 0
11455             NWAMAX = NA
11456             NWBMAX = NB
11457             DO 17 I=0,210
11458                NWA(I) = 0
11459                NWB(I) = 0
11460    17       CONTINUE
11461          ENDIF
11462       ENDIF
11463       IF (NTARG.EQ.-1) THEN
11464          IF (NCOMPO.EQ.0) THEN
11465             WRITE(LOUT,*) ' DIAGR: distribution of wounded nucleons'
11466             WRITE(LOUT,'(8X,A,3I7)') 'NCALL,NWAMAX,NWBMAX = ',
11467      &                                NCALL,NWAMAX,NWBMAX
11468             DO 18 I=1,MAX(NWAMAX,NWBMAX)
11469                WRITE(LOUT,'(8X,2I7,E12.4,I7,E12.4)')
11470      &                          I,NWA(I),DBLE(NWA(I))/DBLE(NCALL),
11471      &                            NWB(I),DBLE(NWB(I))/DBLE(NCALL)
11472    18       CONTINUE
11473          ENDIF
11474          RETURN
11475       ENDIF
11476
11477       DCOH   = 1.0D10
11478       IPNT   = 0
11479
11480       SQ2  = Q2
11481       IF (SQ2.LE.ZERO) SQ2 = 0.0001D0
11482       S   = ECMNOW**2
11483       X   = SQ2/(S+SQ2-AMP2)
11484       XNU = (S+SQ2-AMP2)/(TWO*AMP)
11485 * photon projectiles: recalculate photon-nucleon amplitude
11486       IF (IJPROJ.EQ.7) THEN
11487    15    CONTINUE
11488 *  VDM assumption: mass of V-meson
11489          AMV2   = DT_SAM2(SQ2,ECMNOW)
11490          AMV    = SQRT(AMV2)
11491          IF (AMV.GT.2.0D0*PTCUT(1)) GOTO 15
11492 *  check for pointlike interaction
11493          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,1)
11494 **sr 27.10.
11495 C        SIGSH  = DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11496          SIGSH  = (ONE-RPNT)*DT_SIGVP(X,SQ2)/(AMV2+SQ2+RL2)/10.0D0
11497 **
11498          ROSH   = 0.1D0
11499          BSLOPE = 2.0D0*(2.0D0+AMRHO0**2/(AMV2+SQ2)
11500      &                   +0.25D0*LOG(S/(AMV2+SQ2)))
11501 *  coherence length
11502          IF (ISHAD(3).EQ.1) DCOH = TWO*XNU/(AMV2+SQ2)*GEV2FM
11503       ELSEIF ((IJPROJ.LE.12).AND.(IJPROJ.NE.7)) THEN
11504          IF (MCGENE.EQ.2) THEN
11505             ZERO1 = ZERO
11506             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SDUM1,SDUM2,SDUM3,
11507      &                                                BSLOPE,0)
11508          ELSE
11509             BSLOPE = 8.5D0*(1.0D0+0.065D0*LOG(S))
11510          ENDIF
11511          IF (ECMNOW.LE.3.0D0) THEN
11512             ROSH = -0.43D0
11513          ELSEIF ((ECMNOW.GT.3.0D0).AND.(ECMNOW.LE.50.D0)) THEN
11514             ROSH = -0.63D0+0.175D0*LOG(ECMNOW)
11515          ELSEIF (ECMNOW.GT.50.0D0) THEN
11516             ROSH = 0.1D0
11517          ENDIF
11518          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11519          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11520          IF (MCGENE.EQ.2) THEN
11521             ZERO1 = ZERO
11522             CALL DT_PHOXS(IJPROJ,1,ECMNOW,ZERO1,SIGSH,SDUM2,SDUM3,
11523      &                                                  BDUM,0)
11524             SIGSH = SIGSH/10.0D0
11525          ELSE
11526 C           SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11527             DUMZER = ZERO
11528             CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11529             SIGSH = SIGSH/10.0D0
11530          ENDIF
11531       ELSE
11532          BSLOPE = 6.0D0*(1.0D0+0.065D0*LOG(S))
11533          ROSH   = 0.01D0
11534          ELAB = (S-AAM(IJPROJ)**2-AMP2)/(TWO*AMP)
11535          PLAB = SQRT( (ELAB-AAM(IJPROJ))*(ELAB+AAM(IJPROJ)) )
11536 C        SIGSH = DT_SHNTOT(IJPROJ,1,ZERO,PLAB)/10.0D0
11537          DUMZER = ZERO
11538          CALL DT_XSHN(IJPROJ,1,PLAB,DUMZER,SIGSH,SIGEL)
11539          SIGSH = SIGSH/10.0D0
11540       ENDIF
11541       GSH = 10.0D0/(TWO*BSLOPE*GEV2MB)
11542       GAM = GSH
11543       RCA = GAM*SIGSH/TWOPI
11544       FCA = -ROSH*RCA
11545       CA  = DCMPLX(RCA,FCA)
11546       CI  = DCMPLX(ONE,ZERO)
11547
11548    16 CONTINUE
11549 * impact parameter
11550       IF (MCGENE.NE.3) CALL DT_MODB(B,NIDX)
11551
11552       NTRY = 0
11553     3 CONTINUE
11554       NTRY = NTRY+1
11555 * initializations
11556       JNT  = 0
11557       DO 1 I=1,NA
11558          JS(I) = 0
11559     1 CONTINUE
11560       DO 2 I=1,NB
11561          JT(I) = 0
11562     2 CONTINUE
11563       IF (IJPROJ.EQ.7) THEN
11564          DO 8 I=1,MAXNCL
11565             JS0(I) = 0
11566             JNT0(I)= 0
11567             DO 9 J=1,NB
11568                JT0(I,J) = 0
11569     9       CONTINUE
11570     8    CONTINUE
11571       ENDIF
11572
11573 * nucleon configuration
11574 C     IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,5).EQ.0)) THEN
11575       IF ((NTARG.NE.NTARGO).OR.(MOD(ICNT,1).EQ.0)) THEN
11576 C        CALL DT_CONUCL(PKOO,NA,RASH,2)
11577 C        CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),1)
11578          IF (NIDX.LE.-1) THEN
11579             CALL DT_CONUCL(PKOO,NA,RASH(1),0)
11580             CALL DT_CONUCL(TKOO,NB,RBSH(NTARG),0)
11581          ELSE
11582             CALL DT_CONUCL(PKOO,NA,RASH(NTARG),0)
11583             CALL DT_CONUCL(TKOO,NB,RBSH(1),0)
11584          ENDIF
11585          NTARGO = NTARG
11586       ENDIF
11587       ICNT = ICNT+1
11588
11589 * LEPTO: pick out one struck nucleon
11590       IF (MCGENE.EQ.3) THEN
11591          JNT     = 1
11592          JS(1)   = 1
11593          IDX     = INT(DT_RNDM(X)*NB)+1
11594          JT(IDX) = 1
11595          B       = ZERO
11596          GOTO 19
11597       ENDIF
11598
11599       DO 4 INA=1,NA
11600 * cross section fluctuations
11601          AFLUC = ONE
11602          IF (IFLUCT.EQ.1) THEN
11603             IFLUK = INT((DT_RNDM(X)+0.001D0)*1000.0D0)
11604             AFLUC = FLUIXX(IFLUK)
11605          ENDIF
11606          KK1  = 1
11607          KINT = 1
11608          DO 5 INB=1,NB
11609 * photon-projectile: check for supression by coherence length
11610             IF (IJPROJ.EQ.7) THEN
11611                IF (ABS(TKOO(3,INB)-TKOO(3,KK1)).GT.DCOH) THEN
11612                   KK1  = INB
11613                   KINT = KINT+1
11614                ENDIF
11615             ENDIF
11616             QQ1 = B+TKOO(1,INB)-PKOO(1,INA)
11617             QQ2 =   TKOO(2,INB)-PKOO(2,INA)
11618             XY  = GAM*(QQ1*QQ1+QQ2*QQ2)
11619             IF (XY.LE.15.0D0) THEN
11620                C  = CI-CA*AFLUC*EXP(-XY)
11621                AR = DBLE(C)
11622                AI = DIMAG(C)
11623                P  = AR*AR+AI*AI
11624                IF (DT_RNDM(XY).GE.P) THEN
11625                   JNT = JNT+1
11626                   IF (IJPROJ.EQ.7) THEN
11627                      JNT0(KINT) = JNT0(KINT)+1
11628                      IF (JNT0(KINT).GT.MAXNCL) THEN
11629                         WRITE(LOUT,1001) MAXNCL
11630  1001                   FORMAT(1X,
11631      &                        'DIAGR:  no. of requested interactions',
11632      &                        ' exceeds array dimensions ',I4)
11633                         STOP
11634                      ENDIF
11635                      JS0(KINT)      = JS0(KINT)+1
11636                      JT0(KINT,INB)  = JT0(KINT,INB)+1
11637                      JI1(KINT,JNT0(KINT)) = INA
11638                      JI2(KINT,JNT0(KINT)) = INB
11639                   ELSE
11640                      IF (JNT.GT.MAXINT) THEN
11641                         WRITE(LOUT,1000) JNT, MAXINT
11642  1000                   FORMAT(1X,
11643      &                        'DIAGR:  no. of requested interactions ('
11644      &                        ,I4,') exceeds array dimensions (',I4,')')
11645                         STOP
11646                      ENDIF
11647                      JS(INA) = JS(INA)+1
11648                      JT(INB) = JT(INB)+1
11649                      INTER1(JNT) = INA
11650                      INTER2(JNT) = INB
11651                   ENDIF
11652                ENDIF
11653             ENDIF
11654     5    CONTINUE
11655     4 CONTINUE
11656
11657       IF (JNT.EQ.0) THEN
11658          IF (NTRY.LT.500) THEN
11659             GOTO 3
11660          ELSE
11661 C           WRITE(6,*) ' new impact parameter required (old= ',B,')'
11662             GOTO 16
11663          ENDIF
11664       ENDIF
11665
11666       IDIREC = 0
11667       IF (IJPROJ.EQ.7) THEN
11668          K = INT(ONE+DT_RNDM(X)*DBLE(KINT))
11669    10    CONTINUE
11670          IF (JNT0(K).EQ.0) THEN
11671             K = K+1
11672             IF (K.GT.KINT) K = 1
11673             GOTO 10
11674          ENDIF
11675 * supress Glauber-cascade by direct photon processes
11676          CALL DT_POILIK(NB,NTARG,ECMNOW,SQ2,IPNT,RPNT,2)
11677          IF (IPNT.GT.0) THEN
11678             JNT   = 1
11679             JS(1) = 1
11680             DO 11 INB=1,NB
11681                JT(INB) = JT0(K,INB)
11682                IF (JT(INB).GT.0) GOTO 12
11683    11       CONTINUE
11684    12       CONTINUE
11685             INTER1(1) = 1
11686             INTER2(1) = INB
11687             IDIREC    = IPNT
11688          ELSE
11689             JNT   = JNT0(K)
11690             JS(1) = JS0(K)
11691             DO 13 INB=1,NB
11692                JT(INB) = JT0(K,INB)
11693    13       CONTINUE
11694             DO 14 I=1,JNT
11695                INTER1(I) = JI1(K,I)
11696                INTER2(I) = JI2(K,I)
11697    14       CONTINUE
11698          ENDIF
11699       ENDIF
11700
11701    19 CONTINUE
11702       INTA = 0
11703       INTB = 0
11704       DO 6 I=1,NA
11705         IF (JS(I).NE.0) INTA=INTA+1
11706     6 CONTINUE
11707       DO 7 I=1,NB
11708         IF (JT(I).NE.0) INTB=INTB+1
11709     7 CONTINUE
11710       ICWPG = INTA
11711       ICWTG = INTB
11712       ICIG  = JNT
11713       IPGLB = IPGLB+INTA
11714       ITGLB = ITGLB+INTB
11715       NGLB = NGLB+1
11716
11717       IF (NCOMPO.EQ.0) THEN
11718          NCALL = NCALL+1
11719          NWA(INTA) = NWA(INTA)+1
11720          NWB(INTB) = NWB(INTB)+1
11721       ENDIF
11722
11723       RETURN
11724       END
11725
11726 *$ CREATE DT_MODB.FOR
11727 *COPY DT_MODB
11728 *
11729 *===modb===============================================================*
11730 *
11731       SUBROUTINE DT_MODB(B,NIDX)
11732
11733 ************************************************************************
11734 * Sampling of impact parameter of collision.                           *
11735 *    B          impact parameter    (output)                           *
11736 *    NIDX       index of projectile/target material             (input)*
11737 * Based on the original version by Shmakov et al.                      *
11738 * This version dated 21.04.95 is revised by S. Roesler                 *
11739 *                                                                      *
11740 * Last change 27.12.2006 by S. Roesler.                                *
11741 ************************************************************************
11742
11743       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11744       SAVE
11745
11746       PARAMETER ( LINP = 10 ,
11747      &            LOUT = 6 ,
11748      &            LDAT = 9 )
11749
11750       PARAMETER (ZERO=0.0D0,TINY15=1.0D-15,ONE=1.0D0,TWO=2.0D0)
11751
11752       LOGICAL LEFT,LFIRST
11753
11754 * central particle production, impact parameter biasing
11755       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
11756
11757       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11758
11759 * Glauber formalism: parameters
11760       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11761      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11762      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11763      &                NSITEB,NSTATB
11764
11765 * Glauber formalism: cross sections
11766       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11767      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11768      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11769      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11770      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11771      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11772      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11773      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11774      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11775      &                BSLOPE,NEBINI,NQBINI
11776
11777       DATA LFIRST /.TRUE./
11778
11779       NTARG = ABS(NIDX)
11780       IF (NIDX.LE.-1) THEN
11781          RA = RASH(1)
11782          RB = RBSH(NTARG)
11783       ELSE
11784          RA = RASH(NTARG)
11785          RB = RBSH(1)
11786       ENDIF
11787
11788       IF (ICENTR.EQ.2) THEN
11789          IF (RA.EQ.RB) THEN
11790             BB = DT_RNDM(B)*(0.3D0*RA)**2
11791             B  = SQRT(BB)
11792          ELSEIF(RA.LT.RB)THEN
11793             BB = DT_RNDM(B)*1.4D0*(RB-RA)**2
11794             B  = SQRT(BB)
11795          ELSEIF(RA.GT.RB)THEN
11796             BB = DT_RNDM(B)*1.4D0*(RA-RB)**2
11797             B  = SQRT(BB)
11798          ENDIF
11799       ELSE
11800     9    CONTINUE
11801          Y  = DT_RNDM(BB)
11802          I0 = 1
11803          I2 = NSITEB
11804    10    CONTINUE
11805          I1 = (I0+I2)/2
11806          LEFT = ((BSITE(0,1,NTARG,I0)-Y)
11807      &          *(BSITE(0,1,NTARG,I1)-Y)).LT.ZERO
11808          IF (LEFT) GOTO 20
11809          I0 = I1
11810          GOTO 30
11811    20    CONTINUE
11812          I2 = I1
11813    30    CONTINUE
11814          IF (I2-I0-2) 40,50,60
11815    40    CONTINUE
11816          I1 = I2+1
11817          IF (I1.GT.NSITEB) I1 = I0-1
11818          GOTO 70
11819    50    CONTINUE
11820          I1 = I0+1
11821          GOTO 70
11822    60    CONTINUE
11823          GOTO 10
11824    70    CONTINUE
11825          X0 = DBLE(I0-1)*BSTEP(NTARG)
11826          X1 = DBLE(I1-1)*BSTEP(NTARG)
11827          X2 = DBLE(I2-1)*BSTEP(NTARG)
11828          Y0 = BSITE(0,1,NTARG,I0)
11829          Y1 = BSITE(0,1,NTARG,I1)
11830          Y2 = BSITE(0,1,NTARG,I2)
11831    80    CONTINUE
11832          B = X0*(Y-Y1)*(Y-Y2)/((Y0-Y1)*(Y0-Y2)+TINY15)+
11833      &       X1*(Y-Y0)*(Y-Y2)/((Y1-Y0)*(Y1-Y2)+TINY15)+
11834      &       X2*(Y-Y0)*(Y-Y1)/((Y2-Y0)*(Y2-Y1)+TINY15)
11835 **sr 5.4.98: shift B by half the bin width to be in agreement with BPROD
11836          B = B+0.5D0*BSTEP(NTARG)
11837          IF (B.LT.ZERO) B = X1
11838          IF (B.GT.BMAX(NTARG)) B = BMAX(NTARG)
11839          IF (ICENTR.LT.0) THEN
11840             IF (LFIRST) THEN
11841                LFIRST = .FALSE.
11842                IF (ICENTR.LE.-100) THEN
11843                   BIMIN  = 0.0D0
11844                ELSE
11845                   XSFRAC = 0.0D0
11846                ENDIF
11847                CALL DT_GETBXS(XSFRAC,BIMIN,BIMAX,NTARG)
11848                WRITE(LOUT,1000) RASH(1),RBSH(NTARG),BMAX(NTARG),
11849      &                          BIMIN,BIMAX,XSFRAC*100.0D0,
11850      &                          XSFRAC*XSPRO(1,1,NTARG)
11851  10000         FORMAT(/,1X,'DT_MODB:      Biasing in impact parameter',
11852      &                /,15X,'---------------------------'/,/,4X,
11853      &                'average radii of proj / targ :',F10.3,' fm /',
11854      &                F7.3,' fm',/,4X,'corresp. b_max (4*(r_p+r_t)) :',
11855      &                F10.3,' fm',/,/,21X,'b_lo / b_hi :',
11856      &                F10.3,' fm /',F7.3,' fm',/,5X,'percentage of',
11857      &                ' cross section :',F10.3,' %',/,5X,
11858      &                'corresponding cross section :',F10.3,' mb',/)
11859             ENDIF
11860             IF (ABS(BIMAX-BIMIN).LT.1.0D-3) THEN
11861                B = BIMIN
11862             ELSE
11863                IF ((B.LT.BIMIN).OR.(B.GT.BIMAX)) GOTO 9
11864             ENDIF
11865          ENDIF
11866       ENDIF
11867
11868       RETURN
11869       END
11870
11871 *$ CREATE DT_SHFAST.FOR
11872 *COPY DT_SHFAST
11873 *
11874 *===shfast=============================================================*
11875 *
11876       SUBROUTINE DT_SHFAST(MODE,PPN,IBACK)
11877
11878       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
11879       SAVE
11880
11881       PARAMETER ( LINP = 10 ,
11882      &            LOUT = 6 ,
11883      &            LDAT = 9 )
11884
11885       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY1=1.0D-1,
11886      &           ONE=1.0D0,TWO=2.0D0)
11887
11888       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11889
11890 * Glauber formalism: parameters
11891       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
11892      &                BMAX(NCOMPX),BSTEP(NCOMPX),
11893      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
11894      &                NSITEB,NSTATB
11895
11896 * properties of interacting particles
11897       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
11898
11899 * Glauber formalism: cross sections
11900       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11901      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11902      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11903      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11904      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11905      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
11906      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
11907      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
11908      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
11909      &                BSLOPE,NEBINI,NQBINI
11910
11911       IBACK = 0
11912
11913       IF (MODE.EQ.2) THEN
11914          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11915          WRITE(47,1000) IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG,PPN
11916  1000    FORMAT(1X,8I5,E15.5)
11917          WRITE(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11918  1001    FORMAT(1X,4E15.5)
11919          WRITE(47,1002) SIGSH,ROSH,GSH
11920  1002    FORMAT(1X,3E15.5)
11921          DO 10 I=1,100
11922             WRITE(47,'(1X,E15.5)') BSITE(1,1,1,I)
11923    10    CONTINUE
11924          WRITE(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11925  1003    FORMAT(1X,2I10,3E15.5)
11926          CLOSE(47)
11927       ELSE
11928          OPEN(47,FILE='outdata0/shmakov.out',STATUS='UNKNOWN')
11929          READ(47,1000) JT,JTZ,JP,JPZ,JJPROJ,JBPROJ,JJTARG,JBTARG,PP
11930          IF ((JT.EQ.IT).AND.(JTZ.EQ.ITZ).AND.(JP.EQ.IP).AND.
11931      &       (JPZ.EQ.IPZ).AND.(JJPROJ.EQ.IJPROJ).AND.(JBPROJ.EQ.IBPROJ)
11932      &       .AND.(JJTARG.EQ.IJTARG).AND.(JBTARG.EQ.IBTARG).AND.
11933      &       (ABS(PP-PPN).LT.(PPN*0.01D0))) THEN
11934             READ(47,1001) RASH(1),RBSH(1),BMAX(1),BSTEP(1)
11935             READ(47,1002) SIGSH,ROSH,GSH
11936             DO 11 I=1,100
11937                READ(47,'(1X,E15.5)') BSITE(1,1,1,I)
11938    11       CONTINUE
11939             READ(47,1003) NSITEB,NSTATB,ECMNN(1),XSPRO(1,1,1),BSLOPE
11940          ELSE
11941             IBACK = 1
11942          ENDIF
11943          CLOSE(47)
11944       ENDIF
11945
11946       RETURN
11947       END
11948
11949 *$ CREATE DT_POILIK.FOR
11950 *COPY DT_POILIK
11951 *
11952 *===poilik=============================================================*
11953 *
11954       SUBROUTINE DT_POILIK(NB,NTARG,ECM,VIRT,IPNT,RPNT,MODE)
11955
11956       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
11957       SAVE
11958
11959       PARAMETER ( LINP = 10 ,
11960      &            LOUT = 6 ,
11961      &            LDAT = 9 )
11962
11963       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.0D0)
11964       PARAMETER (NE = 8)
11965
11966 **PHOJET105a
11967 C     CHARACTER*8 MDLNA
11968 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
11969 C     PARAMETER (IEETAB=10)
11970 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
11971 **PHOJET110
11972
11973 C  model switches and parameters
11974       CHARACTER*8 MDLNA
11975       INTEGER ISWMDL,IPAMDL
11976       DOUBLE PRECISION PARMDL
11977       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
11978
11979 C  energy-interpolation table
11980       INTEGER IEETA2
11981       PARAMETER ( IEETA2 = 20 )
11982       INTEGER ISIMAX
11983       DOUBLE PRECISION SIGTAB,SIGECM
11984       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
11985 **
11986
11987 * VDM parameter for photon-nucleus interactions
11988       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
11989 **sr 22.7.97
11990
11991       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
11992
11993 * Glauber formalism: cross sections
11994       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
11995      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
11996      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
11997      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
11998      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
11999      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12000      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12001      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12002      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12003      &                BSLOPE,NEBINI,NQBINI
12004 **
12005
12006       DATA ECMOLD,Q2OLD /-1.0D0,-1.0D0/
12007
12008       IF ((ECM.EQ.ECMOLD).AND.(VIRT.EQ.Q2OLD)) GOTO 3
12009
12010 * load cross sections from interpolation table
12011       IP = 1
12012       IF(ECM.LE.SIGECM(IP,1)) THEN
12013         I1 = 1
12014         I2 = 1
12015       ELSE IF(ECM.LT.SIGECM(IP,ISIMAX)) THEN
12016         DO 50 I=2,ISIMAX
12017           IF(ECM.LE.SIGECM(IP,I)) GOTO 200
12018   50    CONTINUE
12019  200    CONTINUE
12020         I1 = I-1
12021         I2 = I
12022       ELSE
12023         WRITE(LOUT,'(/1X,A,2E12.3)')
12024      &    'POILIK:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
12025         I1 = ISIMAX
12026         I2 = ISIMAX
12027       ENDIF
12028       FAC2 = ZERO
12029       IF(I1.NE.I2) FAC2=LOG(ECM/SIGECM(IP,I1))
12030      &                     /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
12031       FAC1 = ONE-FAC2
12032
12033       SIGANO = DT_SANO(ECM)
12034
12035 * cross section dependence on photon virtuality
12036       FSUP1 = ZERO
12037       DO  150 I=1,3
12038          FSUP1 = FSUP1+PARMDL(26+I)*(ONE+VIRT/(4.D0*PARMDL(30+I)))
12039      &                             /(ONE+VIRT/PARMDL(30+I))**2
12040  150  CONTINUE
12041       FSUP1 = FSUP1+PARMDL(30)/(ONE+VIRT/PARMDL(34))
12042       FAC1  = FAC1*FSUP1
12043       FAC2  = FAC2*FSUP1
12044       FSUP2 = ONE
12045
12046       ECMOLD = ECM
12047       Q2OLD  = VIRT
12048
12049     3 CONTINUE
12050
12051 C     SIGTOT = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
12052       CALL DT_SIGGP(ZERO,VIRT,ECM,ZERO,SIGTOT,DUM1,DUM2)
12053       IF (ISHAD(1).EQ.1) THEN
12054          SIGDIR = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
12055       ELSE
12056          SIGDIR = ZERO
12057       ENDIF
12058       SIGANO = FSUP1*FSUP2*SIGANO
12059       SIGTOT = SIGTOT-SIGDIR-SIGANO
12060       SIGDIR = SIGDIR/(FSUP1*FSUP2)
12061       SIGANO = SIGANO/(FSUP1*FSUP2)
12062       SIGTOT = SIGTOT+SIGDIR+SIGANO
12063
12064       RR = DT_RNDM(SIGTOT)
12065       IF (RR.LT.SIGDIR/SIGTOT) THEN
12066          IPNT = 1
12067       ELSEIF ((RR.GE.SIGDIR/SIGTOT).AND.
12068      &        (RR.LT.(SIGDIR+SIGANO)/SIGTOT)) THEN
12069          IPNT = 2
12070       ELSE
12071          IPNT = 0
12072       ENDIF
12073       RPNT = (SIGDIR+SIGANO)/SIGTOT
12074 C     WRITE(LOUT,'(I3,2F15.5)') ISHAD(1),FAC1,FAC2
12075 C     WRITE(LOUT,'(I3,2F15.5)') MODE,SIGDIR,SIGANO
12076 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SIGDIR+SIGANO,SIGTOT,RPNT,ECM
12077 C     WRITE(LOUT,'(1X,6E12.4)') ECM,VIRT,SIGTOT,SIGDIR,SIGANO,RPNT
12078       IF (MODE.EQ.1) RETURN
12079
12080 **sr 22.7.97
12081       K1   = 1
12082       K2   = 1
12083       RATE = ZERO
12084       IF (ECM.GE.ECMNN(NEBINI)) THEN
12085          K1   = NEBINI
12086          K2   = NEBINI
12087          RATE = ONE
12088       ELSEIF (ECM.GT.ECMNN(1)) THEN
12089          DO 10 I=2,NEBINI
12090             IF (ECM.LT.ECMNN(I)) THEN
12091                K1   = I-1
12092                K2   = I
12093                RATE = (ECM-ECMNN(K1))/(ECMNN(K2)-ECMNN(K1))
12094                GOTO 11
12095             ENDIF
12096    10    CONTINUE
12097    11    CONTINUE
12098       ENDIF
12099       J1   = 1
12100       J2   = 1
12101       RATQ = ZERO
12102       IF (NQBINI.GT.1) THEN
12103          IF (VIRT.GE.Q2G(NQBINI)) THEN
12104             J1   = NQBINI
12105             J2   = NQBINI
12106             RATQ = ONE
12107          ELSEIF (VIRT.GT.Q2G(1)) THEN
12108             DO 12 I=2,NQBINI
12109                IF (VIRT.LT.Q2G(I)) THEN
12110                   J1   = I-1
12111                   J2   = I
12112                   RATQ = LOG10(   VIRT/MAX(Q2G(J1),TINY14))/
12113      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
12114                   GOTO 13
12115                ENDIF
12116    12       CONTINUE
12117    13       CONTINUE
12118          ENDIF
12119       ENDIF
12120       SGA = XSPRO(K1,J1,NTARG)+
12121      &      RATE*(XSPRO(K2,J1,NTARG)-XSPRO(K1,J1,NTARG))+
12122      &      RATQ*(XSPRO(K1,J2,NTARG)-XSPRO(K1,J1,NTARG))+
12123      &      RATE*RATQ*(XSPRO(K2,J2,NTARG)-XSPRO(K1,J2,NTARG)+
12124      &                 XSPRO(K1,J1,NTARG)-XSPRO(K2,J1,NTARG))
12125       SDI = DBLE(NB)*SIGDIR
12126       SAN = DBLE(NB)*SIGANO
12127       SPL = SDI+SAN
12128       RR = DT_RNDM(SPL)
12129       IF (RR.LT.SDI/SGA) THEN
12130          IPNT = 1
12131       ELSEIF ((RR.GE.SDI/SGA).AND.
12132      &        (RR.LT.SPL/SGA)) THEN
12133          IPNT = 2
12134       ELSE
12135          IPNT = 0
12136       ENDIF
12137       RPNT = SPL/SGA
12138 C     WRITE(LOUT,'(I3,4F15.5)') MODE,SPL,SGA,RPNT,ECM
12139 **
12140
12141       RETURN
12142       END
12143
12144 *$ CREATE DT_GLBINI.FOR
12145 *COPY DT_GLBINI
12146 *
12147 *===glbini=============================================================*
12148 *
12149       SUBROUTINE DT_GLBINI(WHAT)
12150
12151 ************************************************************************
12152 * Pre-initialization of profile function                               *
12153 * This version dated 28.11.00 is written by S. Roesler.                *
12154 *                                                                      *
12155 * Last change 27.12.2006 by S. Roesler.                                *
12156 ************************************************************************
12157
12158       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12159       SAVE
12160
12161       PARAMETER ( LINP = 10 ,
12162      &            LOUT = 6 ,
12163      &            LDAT = 9 )
12164
12165       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY14=1.D-14)
12166
12167       LOGICAL LCMS
12168
12169 * particle properties (BAMJET index convention)
12170       CHARACTER*8  ANAME
12171       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12172      &                IICH(210),IIBAR(210),K1(210),K2(210)
12173
12174 * properties of interacting particles
12175       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12176
12177       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12178
12179 * emulsion treatment
12180       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12181      &                NCOMPO,IEMUL
12182
12183 * Glauber formalism: flags and parameters for statistics
12184       LOGICAL LPROD
12185       CHARACTER*8 CGLB
12186       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12187
12188 * number of data sets other than protons and nuclei
12189 * at the moment = 2 (pions and kaons)
12190       PARAMETER (MAXOFF=2)
12191       DIMENSION IJPINI(5),IOFFST(25)
12192       DATA IJPINI / 13, 15,  0,  0,  0/
12193 * Glauber data-set to be used for hadron projectiles
12194 * (0=proton, 1=pion, 2=kaon)
12195       DATA (IOFFST(K),K=1,25) /
12196      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12197      &  0, 0, 1, 2, 2/
12198 * Acceptance interval for target nucleus mass
12199       PARAMETER (KBACC = 6)
12200
12201 * flags for input different options
12202       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12203       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12204      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12205
12206       PARAMETER (MAXMSS = 100)
12207       DIMENSION IASAV(MAXMSS),IBSAV(MAXMSS)
12208       DIMENSION WHAT(6)
12209
12210       DATA JPEACH,JPSTEP / 18, 5 /
12211
12212 * temporary patch until fix has been implemented in phojet:
12213 *  maximum energy for pion projectile
12214       DATA ECMXPI / 100000.0D0 /
12215 *
12216 *--------------------------------------------------------------------------
12217 * general initializations
12218 *
12219 *  steps in projectile mass number for initialization
12220       IF (WHAT(4).GT.ZERO) JPEACH = INT(WHAT(4))
12221       IF (WHAT(5).GT.ZERO) JPSTEP = INT(WHAT(5))
12222 *
12223 *  energy range and binning
12224       ELO  = ABS(WHAT(1))
12225       EHI  = ABS(WHAT(2))
12226       IF (ELO.GT.EHI) ELO = EHI
12227       NEBIN = MAX(INT(WHAT(3)),1)
12228       IF (ELO.EQ.EHI) NEBIN = 0
12229       LCMS = (WHAT(1).LT.ZERO).OR.(WHAT(2).LT.ZERO)
12230       IF (LCMS) THEN
12231          ECMINI = EHI
12232       ELSE
12233          ECMINI = SQRT(AAM(IJPROJ)**2+AAM(IJTARG)**2
12234      &                 +2.0D0*AAM(IJTARG)*EHI)
12235       ENDIF
12236 *
12237 *  default arguments for Glauber-routine
12238       XI  = ZERO
12239       Q2I = ZERO
12240 *
12241 *  initialize nuclear parameters, etc.
12242
12243 *  initialize evaporation if the code is not used as Fluka event generator
12244       IF (ITRSPT.NE.1) THEN
12245          CALL NCDTRD
12246          CALL INCINI
12247       ENDIF
12248
12249 *
12250 *  open Glauber-data output file
12251       IDX = INDEX(CGLB,' ')
12252       K   = 12
12253       IF (IDX.GT.1) K = IDX-1
12254       OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12255 *
12256 *--------------------------------------------------------------------------
12257 * Glauber-initialization for proton and nuclei projectiles
12258 *
12259 *  initialize phojet for proton-proton interactions
12260       ELAB = ZERO
12261       PLAB = ZERO
12262       CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12263       CALL DT_PHOINI
12264 *
12265 *  record projectile masses
12266       NASAV = 0
12267       NPROJ = MIN(IP,JPEACH)
12268       DO 10 KPROJ=1,NPROJ
12269          NASAV = NASAV+1
12270          IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12271          IASAV(NASAV) = KPROJ
12272    10 CONTINUE
12273       IF (IP.GT.JPEACH) THEN
12274          NPROJ = DBLE(IP-JPEACH)/DBLE(JPSTEP)
12275          IF (NPROJ.EQ.0) THEN
12276             NASAV = NASAV+1
12277             IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12278             IASAV(NASAV) = IP
12279          ELSE
12280             DO 11 IPROJ=1,NPROJ
12281                KPROJ = JPEACH+IPROJ*JPSTEP
12282                NASAV = NASAV+1
12283                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12284                IASAV(NASAV) = KPROJ
12285    11       CONTINUE
12286             IF (KPROJ.LT.IP) THEN
12287                NASAV = NASAV+1
12288                IF (NASAV.GT.MAXMSS) STOP ' GLBINI: NASAV > MAXMSS ! '
12289                IASAV(NASAV) = IP
12290             ENDIF
12291          ENDIF
12292       ENDIF
12293 *
12294 *  record target masses
12295       NBSAV = 0
12296       NTARG = 1
12297       IF (NCOMPO.GT.0) NTARG = NCOMPO
12298       DO 12 ITARG=1,NTARG
12299          NBSAV = NBSAV+1
12300          IF (NBSAV.GT.MAXMSS) STOP ' GLBINI: NBSAV > MAXMSS ! '
12301          IF (NCOMPO.GT.0) THEN
12302             IBSAV(NBSAV) = IEMUMA(ITARG)
12303          ELSE
12304             IBSAV(NBSAV) = IT
12305          ENDIF
12306    12 CONTINUE
12307 *
12308 *  print masses
12309       WRITE(LDAT,1000) NEBIN,': ',SIGN(ELO,WHAT(1)),SIGN(EHI,WHAT(2))
12310  1000 FORMAT(I4,A,1P,2E13.5)
12311       NLINES = DBLE(NASAV)/18.0D0
12312       IF (NLINES.GT.0) THEN
12313          DO 13 I=1,NLINES
12314             IF (I.EQ.1) THEN
12315                WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=1,18)
12316             ELSE
12317                WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=18*I-17,18*I)
12318             ENDIF
12319    13    CONTINUE
12320       ENDIF
12321       I0 = 18*NLINES+1
12322       IF (I0.LE.NASAV) THEN
12323          IF (I0.EQ.1) THEN
12324             WRITE(LDAT,'(I4,A,18I4)')NASAV,': ',(IASAV(J),J=I0,NASAV)
12325          ELSE
12326             WRITE(LDAT,'(6X,18I4)') (IASAV(J),J=I0,NASAV)
12327          ENDIF
12328       ENDIF
12329       NLINES = DBLE(NBSAV)/18.0D0
12330       IF (NLINES.GT.0) THEN
12331          DO 14 I=1,NLINES
12332             IF (I.EQ.1) THEN
12333                WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=1,18)
12334             ELSE
12335                WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=18*I-17,18*I)
12336             ENDIF
12337    14    CONTINUE
12338       ENDIF
12339       I0 = 18*NLINES+1
12340       IF (I0.LE.NBSAV) THEN
12341          IF (I0.EQ.1) THEN
12342             WRITE(LDAT,'(I4,A,18I4)')NBSAV,': ',(IBSAV(J),J=I0,NBSAV)
12343          ELSE
12344             WRITE(LDAT,'(6X,18I4)') (IBSAV(J),J=I0,NBSAV)
12345          ENDIF
12346       ENDIF
12347 *
12348 *  calculate Glauber-data for each energy and mass combination
12349 *
12350 *   loop over energy bins
12351       ELO = LOG10(ELO)
12352       EHI = LOG10(EHI)
12353       DEBIN = (EHI-ELO)/MAX(DBLE(NEBIN),ONE)
12354       DO 1 IE=1,NEBIN+1
12355          E = ELO+DBLE(IE-1)*DEBIN
12356          E = 10**E
12357          IF (LCMS) THEN
12358             E   = MAX(2.0D0*AAM(IJPROJ)+0.1D0,E)
12359             ECM = E
12360          ELSE
12361             PLAB = ZERO
12362             ECM  = ZERO
12363             E    = MAX(AAM(IJPROJ)+0.1D0,E)
12364             CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12365          ENDIF
12366 *
12367 *   loop over projectile and target masses
12368          DO 2 ITARG=1,NBSAV
12369             DO 3 IPROJ=1,NASAV
12370                CALL DT_XSGLAU(IASAV(IPROJ),IBSAV(ITARG),IJPROJ,
12371      &                                       XI,Q2I,ECM,1,1,-1)
12372     3       CONTINUE
12373     2    CONTINUE
12374 *
12375     1 CONTINUE
12376 *
12377 *--------------------------------------------------------------------------
12378 * Glauber-initialization for pion, kaon, ... projectiles
12379 *
12380       DO 6 IJ=1,MAXOFF
12381 *
12382 *  initialize phojet for this interaction
12383          ELAB = ZERO
12384          PLAB = ZERO
12385          IJPROJ = IJPINI(IJ)
12386          IP     = 1
12387          IPZ    = 1
12388 *
12389 *   temporary patch until fix has been implemented in phojet:
12390          IF (ECMINI.GT.ECMXPI) THEN
12391             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMXPI,1)
12392          ELSE
12393             CALL DT_LTINI(IJPROJ,IJTARG,ELAB,PLAB,ECMINI,1)
12394          ENDIF
12395          CALL DT_PHOINI
12396 *
12397 *  calculate Glauber-data for each energy and mass combination
12398 *
12399 *   loop over energy bins
12400          DO 4 IE=1,NEBIN+1
12401             E = ELO+DBLE(IE-1)*DEBIN
12402             E = 10**E
12403             IF (LCMS) THEN
12404                E   = MAX(2.0D0*AAM(IJPROJ)+TINY14,E)
12405                ECM = E
12406             ELSE
12407                PLAB = ZERO
12408                ECM  = ZERO
12409                E    = MAX(AAM(IJPROJ)+TINY14,E)
12410                CALL DT_LTINI(IJPROJ,IJTARG,E,PLAB,ECM,0)
12411             ENDIF
12412 *
12413 *   loop over projectile and target masses
12414             DO 5 ITARG=1,NBSAV
12415                CALL DT_XSGLAU(1,IBSAV(ITARG),IJPROJ,XI,Q2I,ECM,1,1,-1)
12416     5       CONTINUE
12417 *
12418     4    CONTINUE
12419 *
12420     6 CONTINUE
12421
12422 *--------------------------------------------------------------------------
12423 * close output unit(s), etc.
12424 *
12425       CLOSE(LDAT)
12426
12427       RETURN
12428       END
12429
12430 *$ CREATE DT_GLBSET.FOR
12431 *COPY DT_GLBSET
12432 *
12433 *===glbset=============================================================*
12434 *
12435       SUBROUTINE DT_GLBSET(IDPROJ,NA,NB,ELAB,MODE)
12436 ************************************************************************
12437 * Interpolation of pre-initialized profile functions                   *
12438 * This version dated 28.11.00 is written by S. Roesler.                *
12439 ************************************************************************
12440
12441       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12442       SAVE
12443
12444       PARAMETER ( LINP = 10 ,
12445      &            LOUT = 6 ,
12446      &            LDAT = 9 )
12447
12448       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
12449
12450       LOGICAL LCMS,LREAD,LFRST1,LFRST2
12451
12452 * particle properties (BAMJET index convention)
12453       CHARACTER*8  ANAME
12454       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12455      &                IICH(210),IIBAR(210),K1(210),K2(210)
12456
12457 * Glauber formalism: flags and parameters for statistics
12458       LOGICAL LPROD
12459       CHARACTER*8 CGLB
12460       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
12461
12462       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
12463
12464 * Glauber formalism: parameters
12465       COMMON /DTGLAM/ RASH(NCOMPX),RBSH(NCOMPX),
12466      &                BMAX(NCOMPX),BSTEP(NCOMPX),
12467      &                SIGSH,ROSH,GSH,BSITE(0:NEB,NQB,NCOMPX,KSITEB),
12468      &                NSITEB,NSTATB
12469
12470 * Glauber formalism: cross sections
12471       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
12472      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
12473      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
12474      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
12475      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
12476      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
12477      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
12478      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
12479      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
12480      &                BSLOPE,NEBINI,NQBINI
12481
12482 * number of data sets other than protons and nuclei
12483 * at the moment = 2 (pions and kaons)
12484       PARAMETER (MAXOFF=2)
12485       DIMENSION IJPINI(5),IOFFST(25)
12486       DATA IJPINI / 13, 15,  0,  0,  0/
12487 * Glauber data-set to be used for hadron projectiles
12488 * (0=proton, 1=pion, 2=kaon)
12489       DATA (IOFFST(K),K=1,25) /
12490      &  0, 0,-1,-1,-1,-1,-1, 0, 0,-1,-1, 2, 1, 1, 2, 2, 0, 0, 2, 0,
12491      &  0, 0, 1, 2, 2/
12492 * Acceptance interval for target nucleus mass
12493       PARAMETER (KBACC = 6)
12494
12495 * emulsion treatment
12496       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
12497      &                NCOMPO,IEMUL
12498
12499       PARAMETER (MAXSET=5000,
12500      &           MAXBIN=100)
12501       DIMENSION XSIG(MAXSET,6),XERR(MAXSET,6),BPROFL(MAXSET,KSITEB)
12502       DIMENSION IABIN(MAXBIN),IBBIN(MAXBIN),XS(6),XE(6),
12503      &          BPRO0(KSITEB),BPRO1(KSITEB),BPRO(KSITEB),
12504      &          IAIDX(10)
12505
12506       DATA LREAD,LFRST1,LFRST2 /.FALSE.,.TRUE.,.TRUE./
12507 *
12508 * read data from file
12509 *
12510       IF (MODE.EQ.0) THEN
12511
12512          IF (LREAD) RETURN
12513
12514          DO 1 I=1,MAXSET
12515             DO 2 J=1,6
12516                XSIG(I,J) = ZERO
12517                XERR(I,J) = ZERO
12518     2       CONTINUE
12519             DO 3 J=1,KSITEB
12520                BPROFL(I,J) = ZERO
12521     3       CONTINUE
12522     1    CONTINUE
12523          DO 4 I=1,MAXBIN
12524             IABIN(I) = 0
12525             IBBIN(I) = 0
12526     4    CONTINUE
12527          DO 5 I=1,KSITEB
12528             BPRO0(I) = ZERO
12529             BPRO1(I) = ZERO
12530             BPRO(I)  = ZERO
12531     5    CONTINUE
12532
12533          IDX = INDEX(CGLB,' ')
12534          K   = 12
12535          IF (IDX.GT.1) K = IDX-1
12536          OPEN(LDAT,FILE=CGLB(1:K)//'.glb',STATUS='UNKNOWN')
12537          WRITE(LOUT,1000) CGLB(1:K)//'.glb'
12538  1000    FORMAT(/,' GLBSET: impact parameter distributions read from ',
12539      &          'file ',A12,/)
12540 *
12541 *  read binning information
12542          READ(LDAT,'(I4,2X,2E13.5)') NEBIN,ELO,EHI
12543 *  return lower energy threshold to Fluka-interface
12544          ELAB = ELO
12545          LCMS = ELO.LT.ZERO
12546          WRITE(LOUT,'(1X,A)') ' equidistant logarithmic energy binning:'
12547          IF (LCMS) THEN
12548             WRITE(LOUT,1001) '(cms)',ABS(ELO),ABS(EHI),NEBIN
12549          ELSE
12550             WRITE(LOUT,1001) '(lab)',ABS(ELO),ABS(EHI),NEBIN
12551          ENDIF
12552  1001    FORMAT(2X,A5,'  E_lo = ',1P,E9.3,'  E_hi = ',1P,E9.3,4X,
12553      &          'No. of bins:',I5,/)
12554          ELO  = LOG10(ABS(ELO))
12555          EHI  = LOG10(ABS(EHI))
12556          DEBIN = (EHI-ELO)/ABS(DBLE(NEBIN))
12557          WRITE(LOUT,'(/,1X,A)') ' projectiles: (mass number)'
12558          READ(LDAT,'(I4,2X,18I4)') NABIN,(IABIN(J),J=1,18)
12559          IF (NABIN.LT.18) THEN
12560             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,NABIN)
12561          ELSE
12562             WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=1,18)
12563          ENDIF
12564          IF (NABIN.GT.MAXBIN) STOP ' GLBSET: NABIN > MAXBIN !'
12565          IF (NABIN.GT.18) THEN
12566             NLINES = DBLE(NABIN-18)/18.0D0
12567             IF (NLINES.GT.0) THEN
12568                DO 7 I=1,NLINES
12569                   I0 = 18*(I+1)-17
12570                   READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12571                   WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,I0+17)
12572     7          CONTINUE
12573             ENDIF
12574             I0 = 18*(NLINES+1)+1
12575             IF (I0.LE.NABIN) THEN
12576                READ(LDAT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12577                WRITE(LOUT,'(6X,18I4)') (IABIN(J),J=I0,NABIN)
12578             ENDIF
12579          ENDIF
12580          WRITE(LOUT,'(/,1X,A)') ' targets: (mass number)'
12581          READ(LDAT,'(I4,2X,18I4)') NBBIN,(IBBIN(J),J=1,18)
12582          IF (NBBIN.LT.18) THEN
12583             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,NBBIN)
12584          ELSE
12585             WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=1,18)
12586          ENDIF
12587          IF (NBBIN.GT.MAXBIN) STOP ' GLBSET: NBBIN > MAXBIN !'
12588          IF (NBBIN.GT.18) THEN
12589             NLINES = DBLE(NBBIN-18)/18.0D0
12590             IF (NLINES.GT.0) THEN
12591                DO 8 I=1,NLINES
12592                   I0 = 18*(I+1)-17
12593                   READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12594                   WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,I0+17)
12595     8          CONTINUE
12596             ENDIF
12597             I0 = 18*(NLINES+1)+1
12598             IF (I0.LE.NBBIN) THEN
12599                READ(LDAT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12600                WRITE(LOUT,'(6X,18I4)') (IBBIN(J),J=I0,NBBIN)
12601             ENDIF
12602          ENDIF
12603 *  number of data sets to follow in the Glauber data file
12604 *   this variable is used for checks of consistency of projectile
12605 *   and target mass configurations given in header of Glauber data
12606 *   file and the data-sets which follow in this file
12607          NSET0 = (NEBIN+1)*(NABIN+MAXOFF)*NBBIN
12608 *
12609 *  read profile function data
12610          NSET  = 0
12611          NAIDX = 0
12612          IPOLD = 0
12613    10    CONTINUE
12614          NSET = NSET+1
12615          IF (NSET.GT.MAXSET) STOP ' GLBSET: NSET > MAXSET ! '
12616          READ(LDAT,1002,END=100) IP,IA,IB,ISTATB,ISITEB,ECM
12617  1002    FORMAT(5I10,E15.5)
12618          IF ((IP.NE.1).AND.(IP.NE.IPOLD)) THEN
12619             NAIDX = NAIDX+1
12620             IF (NAIDX.GT.10) STOP ' GLBSET: NAIDX > 10 !'
12621             IAIDX(NAIDX) = IP
12622             IPOLD = IP
12623          ENDIF
12624          READ(LDAT,'(6E12.5)') (XSIG(NSET,I),I=1,6)
12625          READ(LDAT,'(6E12.5)') (XERR(NSET,I),I=1,6)
12626          NLINES = INT(DBLE(ISITEB)/7.0D0)
12627          IF (NLINES.GT.0) THEN
12628             DO 11 I=1,NLINES
12629                READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=7*I-6,7*I)
12630    11       CONTINUE
12631          ENDIF
12632          I0 = 7*NLINES+1
12633          IF (I0.LE.ISITEB)
12634      &      READ(LDAT,'(7E11.4)') (BPROFL(NSET,J),J=I0,ISITEB)
12635          GOTO 10
12636   100    CONTINUE
12637          NSET = NSET-1
12638          IF (NSET.NE.NSET0) STOP ' GLBSET: NSET.NE.NSET0 !'
12639          WRITE(LOUT,'(/,1X,A)')
12640      &   ' projectiles other than protons and nuclei: (particle index)'
12641          IF (NAIDX.GT.0) THEN
12642             WRITE(LOUT,'(6X,18I4)') (IAIDX(J),J=1,NAIDX)
12643          ELSE
12644             WRITE(LOUT,'(6X,A)') 'none'
12645          ENDIF
12646 *
12647          CLOSE(LDAT)
12648          WRITE(LOUT,*)
12649          LREAD = .TRUE.
12650
12651          IF (NCOMPO.EQ.0) THEN
12652             DO 12 J=1,NBBIN
12653                NCOMPO = NCOMPO+1
12654                IEMUMA(NCOMPO) = IBBIN(J)
12655                IEMUCH(NCOMPO) = IEMUMA(NCOMPO)/2
12656                EMUFRA(NCOMPO) = 1.0D0
12657    12       CONTINUE
12658             IEMUL = 1
12659          ENDIF
12660 *
12661 * calculate profile function for certain set of parameters
12662 *
12663       ELSE
12664
12665 c        write(*,*) 'glbset called for ',IDPROJ,NA,NB,ELAB,MODE
12666 *
12667 * check for type of projectile and set index-offset to entry in
12668 * Glauber data array correspondingly
12669          IF (IDPROJ.GT.25) STOP ' GLBSET: IDPROJ > 25 !'
12670          IF (IOFFST(IDPROJ).EQ.-1) THEN
12671             STOP ' GLBSET: no data for this projectile !'
12672          ELSEIF (IOFFST(IDPROJ).GT.0) THEN
12673             IDXOFF = (NEBIN+1)*(NABIN+IOFFST(IDPROJ)-1)*NBBIN
12674          ELSE
12675             IDXOFF = 0
12676          ENDIF
12677 *
12678 * get energy bin and interpolation factor
12679          IF (LCMS) THEN
12680             E = SQRT(AAM(IDPROJ)**2+AAM(1)**2+2.0D0*AAM(1)*ELAB)
12681          ELSE
12682             E = ELAB
12683          ENDIF
12684          E = LOG10(E)
12685          IF (E.LT.ELO) THEN
12686             IF (LFRST1) THEN
12687                WRITE(LOUT,*) ' GLBSET: Too low energy! (E_lo,E) ',ELO,E
12688                LFRST1 = .FALSE.
12689             ENDIF
12690             E = ELO
12691          ENDIF
12692          IF (E.GT.EHI) THEN
12693             IF (LFRST2) THEN
12694                WRITE(LOUT,*) ' GLBSET: Too high energy! (E_hi,E) ',EHI,E
12695                LFRST2 = .FALSE.
12696             ENDIF
12697             E = EHI
12698          ENDIF
12699          IE0  = (E-ELO)/DEBIN+1
12700          IE1  = IE0+1
12701          FACE = (E-(ELO+DBLE(IE0-1)*DEBIN))/DEBIN
12702 *
12703 * get target nucleus index
12704          KB = 0
12705          NBACC = KBACC
12706          DO 20 I=1,NBBIN
12707             NBDIFF = ABS(NB-IBBIN(I))
12708             IF (NB.EQ.IBBIN(I)) THEN
12709                KB = I
12710                GOTO 21
12711             ELSEIF (NBDIFF.LE.NBACC) THEN
12712                KB = I
12713                NBACC = NBDIFF
12714             ENDIF
12715    20    CONTINUE
12716          IF (KB.NE.0) GOTO 21
12717          WRITE(LOUT,*) ' GLBSET: data not found for target ',NB
12718          STOP
12719    21    CONTINUE
12720 *
12721 * get projectile nucleus bin and interpolation factor
12722          KA0 = 0
12723          KA1 = 0
12724          FACNA = 0
12725          IF (IDXOFF.GT.0) THEN
12726             KA0 = 1
12727             KA1 = 1
12728             KABIN = 1
12729          ELSE
12730             IF (NA.GT.IABIN(NABIN)) STOP ' GLBSET: NA > IABIN(NABIN) !'
12731             DO 22 I=1,NABIN
12732                IF (NA.EQ.IABIN(I)) THEN
12733                   KA0 = I
12734                   KA1 = I
12735                   GOTO 23
12736                ELSEIF (NA.LT.IABIN(I)) THEN
12737                   KA0 = I-1
12738                   KA1 = I
12739                   GOTO 23
12740                ENDIF
12741    22       CONTINUE
12742             WRITE(LOUT,*) ' GLBSET: data not found for projectile ',NA
12743             STOP
12744    23       CONTINUE
12745             IF (KA0.NE.KA1)
12746      &         FACNA = DBLE(NA-IABIN(KA0))/DBLE(IABIN(KA1)-IABIN(KA0))
12747             KABIN = NABIN
12748          ENDIF
12749 *
12750 * interpolate profile functions for interactions ka0-kb and ka1-kb
12751 * for energy E separately
12752          IDX0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12753          IDX1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA0-1)
12754          IDY0 = IDXOFF+1+(IE0-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12755          IDY1 = IDXOFF+1+(IE1-1)*KABIN*NBBIN+(KB-1)*KABIN+(KA1-1)
12756          DO 30 I=1,ISITEB
12757             BPRO0(I) = BPROFL(IDX0,I)
12758      &                 +FACE*(BPROFL(IDX1,I)-BPROFL(IDX0,I))
12759             BPRO1(I) = BPROFL(IDY0,I)
12760      &                 +FACE*(BPROFL(IDY1,I)-BPROFL(IDY0,I))
12761    30    CONTINUE
12762          RADB  = DT_RNCLUS(NB)
12763          BSTP0 = 2.0D0*(DT_RNCLUS(IABIN(KA0))+RADB)/DBLE(ISITEB-1)
12764          BSTP1 = 2.0D0*(DT_RNCLUS(IABIN(KA1))+RADB)/DBLE(ISITEB-1)
12765 *
12766 * interpolate cross sections for energy E and projectile mass
12767          DO 31 I=1,6
12768             XS0   = XSIG(IDX0,I)+FACE*(XSIG(IDX1,I)-XSIG(IDX0,I))
12769             XS1   = XSIG(IDY0,I)+FACE*(XSIG(IDY1,I)-XSIG(IDY0,I))
12770             XS(I) = XS0+FACNA*(XS1-XS0)
12771             XE0   = XERR(IDX0,I)+FACE*(XERR(IDX1,I)-XERR(IDX0,I))
12772             XE1   = XERR(IDY0,I)+FACE*(XERR(IDY1,I)-XERR(IDY0,I))
12773             XE(I) = XE0+FACNA*(XE1-XE0)
12774    31    CONTINUE
12775 *
12776 * interpolate between ka0 and ka1
12777          RADA = DT_RNCLUS(NA)
12778          BMX  = 2.0D0*(RADA+RADB)
12779          BSTP = BMX/DBLE(ISITEB-1)
12780          BPRO(1) = ZERO
12781          DO 32 I=1,ISITEB-1
12782             B = DBLE(I)*BSTP
12783 *
12784 *   calculate values of profile functions at B
12785             IDX0 = B/BSTP0+1
12786             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12787             IDX1 = MIN(IDX0+1,ISITEB)
12788             FACB = (B-DBLE(IDX0-1)*BSTP0)/BSTP0
12789             BPR0 = BPRO0(IDX0)+FACB*(BPRO0(IDX1)-BPRO0(IDX0))
12790             IDX0 = B/BSTP1+1
12791             IF (IDX0.GT.ISITEB) IDX0 = ISITEB
12792             IDX1 = MIN(IDX0+1,ISITEB)
12793             FACB = (B-DBLE(IDX0-1)*BSTP1)/BSTP1
12794             BPR1 = BPRO1(IDX0)+FACB*(BPRO1(IDX1)-BPRO1(IDX0))
12795 *
12796             BPRO(I+1) = BPR0+FACNA*(BPR1-BPR0)
12797    32    CONTINUE
12798 *
12799 * fill common dtglam
12800          NSITEB   = ISITEB
12801          RASH(1)  = RADA
12802          RBSH(1)  = RADB
12803          BMAX(1)  = BMX
12804          BSTEP(1) = BSTP
12805          DO 33 I=1,KSITEB
12806             BSITE(0,1,1,I) = BPRO(I)
12807    33    CONTINUE
12808 *
12809 * fill common dtglxs
12810          XSTOT(1,1,1) = XS(1)
12811          XSELA(1,1,1) = XS(2)
12812          XSQEP(1,1,1) = XS(3)
12813          XSQET(1,1,1) = XS(4)
12814          XSQE2(1,1,1) = XS(5)
12815          XSPRO(1,1,1) = XS(6)
12816          XETOT(1,1,1) = XE(1)
12817          XEELA(1,1,1) = XE(2)
12818          XEQEP(1,1,1) = XE(3)
12819          XEQET(1,1,1) = XE(4)
12820          XEQE2(1,1,1) = XE(5)
12821          XEPRO(1,1,1) = XE(6)
12822
12823       ENDIF
12824
12825       RETURN
12826       END
12827 *$ CREATE DT_XKSAMP.FOR
12828 *COPY DT_XKSAMP
12829 *
12830 *===xksamp=============================================================*
12831 *
12832       SUBROUTINE DT_XKSAMP(NN,ECM)
12833
12834 ************************************************************************
12835 * Sampling of parton x-values and chain system for one interaction.    *
12836 *                                   processed by S. Roesler, 9.8.95    *
12837 ************************************************************************
12838
12839       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
12840       SAVE
12841
12842       PARAMETER ( LINP = 10 ,
12843      &            LOUT = 6 ,
12844      &            LDAT = 9 )
12845
12846       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
12847       SAVE
12848
12849       PARAMETER (
12850 * lower cuts for (valence-sea/sea-valence) chain masses
12851 *   antiquark-quark (u/d-sea quark)    (s-sea quark)
12852      &               AMIU = 0.5D0,      AMIS = 0.8D0,
12853 *   quark-diquark   (u/d-sea quark)    (s-sea quark)
12854      &               AMAU = 2.6D0,      AMAS = 2.6D0,
12855 * maximum lower valence-x threshold
12856      &           XVMAX  = 0.98D0,
12857 * fraction of sea-diquarks sampled out of sea-partons
12858 **test
12859 C    &           FRCDIQ = 0.9D0,
12860 **
12861 *
12862      &           SQMA   = 0.7D0,
12863 *
12864 * maximum number of trials to generate x's for the required number
12865 * of sea quark pairs for a given hadron
12866      &           NSEATY = 12
12867 C    &           NSEATY = 3
12868      &          )
12869
12870       LOGICAL ZUOVP,ZUOSP,ZUOVT,ZUOST,INTLO
12871
12872       PARAMETER ( MAXNCL = 260,
12873
12874      &            MAXVQU = MAXNCL,
12875      &            MAXSQU = 20*MAXVQU,
12876      &            MAXINT = MAXVQU+MAXSQU)
12877
12878 * event history
12879
12880       PARAMETER (NMXHKK=200000)
12881
12882       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
12883      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
12884      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
12885
12886 * particle properties (BAMJET index convention)
12887       CHARACTER*8  ANAME
12888       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
12889      &                IICH(210),IIBAR(210),K1(210),K2(210)
12890
12891 * interface between Glauber formalism and DPM
12892       COMMON /DTGLIF/ JSSH(MAXNCL),JTSH(MAXNCL),
12893      &                INTER1(MAXINT),INTER2(MAXINT)
12894
12895 * properties of interacting particles
12896       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
12897
12898 * threshold values for x-sampling (DTUNUC 1.x)
12899       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
12900      &                SSMIMQ,VVMTHR
12901
12902 * x-values of partons (DTUNUC 1.x)
12903       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
12904      &                XTVQ(MAXVQU),XTVD(MAXVQU),
12905      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
12906      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
12907
12908 * flavors of partons (DTUNUC 1.x)
12909       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
12910      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
12911      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
12912      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
12913      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
12914      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
12915      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
12916
12917 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12918       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
12919      &                IXPV,IXPS,IXTV,IXTS,
12920      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
12921      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
12922      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
12923      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
12924      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
12925      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
12926      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
12927      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
12928
12929 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
12930       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
12931      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
12932
12933 * auxiliary common for chain system storage (DTUNUC 1.x)
12934       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
12935
12936 * flags for input different options
12937       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
12938       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
12939      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
12940
12941 * various options for treatment of partons (DTUNUC 1.x)
12942 * (chain recombination, Cronin,..)
12943       LOGICAL LCO2CR,LINTPT
12944       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
12945      &                LCO2CR,LINTPT
12946
12947       DIMENSION ZUOVP(MAXVQU),ZUOSP(MAXSQU),ZUOVT(MAXVQU),ZUOST(MAXSQU),
12948      &          INTLO(MAXINT)
12949
12950 * (1) initializations
12951 *-----------------------------------------------------------------------
12952
12953 **test
12954       IF (ECM.LT.4.5D0) THEN
12955 C        FRCDIQ = 0.6D0
12956          FRCDIQ = 0.4D0
12957       ELSEIF ((ECM.GE.4.5D0).AND.(ECM.LT.7.5)) THEN
12958 C        FRCDIQ = 0.6D0+(ECM-4.5D0)/3.0D0*0.3D0
12959          FRCDIQ = 0.4D0+(ECM-4.5D0)/3.0D0*0.3D0
12960       ELSE
12961 C        FRCDIQ = 0.9D0
12962          FRCDIQ = 0.7D0
12963       ENDIF
12964 **
12965       DO 30 I=1,MAXSQU
12966          ZUOSP(I) = .FALSE.
12967          ZUOST(I) = .FALSE.
12968          IF (I.LE.MAXVQU) THEN
12969             ZUOVP(I) = .FALSE.
12970             ZUOVT(I) = .FALSE.
12971          ENDIF
12972    30 CONTINUE
12973
12974 * lower thresholds for x-selection
12975 *  sea-quarks       (default: CSEA=0.2)
12976       IF (ECM.LT.10.0D0) THEN
12977 **!!test
12978          XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM
12979 C        XSTHR = ((12.0D0-ECM)/5.0D0+1.0D0)*CSEA/ECM**2.0D0
12980          NSEA  = NSEATY
12981 C        XSTHR = ONE/ECM**2
12982       ELSE
12983 **sr 30.3.98
12984 C        XSTHR = CSEA/ECM
12985          XSTHR = CSEA/ECM**2
12986 C        XSTHR = ONE/ECM**2
12987 **
12988          IF ((IP.GE.150).AND.(IT.GE.150))
12989      &      XSTHR = 2.5D0/(ECM*SQRT(ECM))
12990          NSEA  = NSEATY
12991       ENDIF
12992 *                   (default: SSMIMA=0.14) used for sea-diquarks (?)
12993       XSSTHR = SSMIMA/ECM
12994       BSQMA  = SQMA/ECM
12995 *  valence-quarks   (default: CVQ=1.0)
12996       XVTHR  = CVQ/ECM
12997 *  valence-diquarks (default: CDQ=2.0)
12998       XDTHR  = CDQ/ECM
12999
13000 * maximum-x for sea-quarks
13001       XVCUT  = XVTHR+XDTHR
13002       IF (XVCUT.GT.XVMAX) THEN
13003          XVCUT = XVMAX
13004          XVTHR = XVCUT/3.0D0
13005          XDTHR = XVCUT-XVTHR
13006       ENDIF
13007       XXSEAM = ONE-XVCUT
13008 **sr 18.4. test: DPMJET
13009 C     XXSEAM=1.0 - XVTHR*(1.D0+0.3D0*DT_RNDM(V1))
13010 C    &            - XDTHR*(1.D0+0.3D0*DT_RNDM(V2))
13011 C    &             -0.01*(1.D0+1.5D0*DT_RNDM(V3))
13012 **
13013 * maximum number of sea-pairs allowed kinematically
13014 C     NSMAX  = INT(OHALF*XXSEAM/XSTHR)
13015       RNSMAX = OHALF*XXSEAM/XSTHR
13016       IF (RNSMAX.GT.10000.0D0) THEN
13017          NSMAX = 10000
13018       ELSE
13019          NSMAX = INT(OHALF*XXSEAM/XSTHR)
13020       ENDIF
13021 * check kinematical limit for valence-x thresholds
13022 * (should be obsolete now)
13023       IF (XVCUT.GT.XVMAX) THEN
13024          WRITE(LOUT,1000) XVCUT,ECM
13025  1000    FORMAT(' XKSAMP:    kin. limit for valence-x',
13026      &          '  thresholds not allowed (',2E9.3,')')
13027 C        XVTHR = XVMAX-XDTHR
13028 C        IF (XVTHR.LT.ZERO) STOP
13029          STOP
13030       ENDIF
13031
13032 * set eta for valence-x sampling (BETREJ)
13033 *   (UNON per default, UNOM used for projectile mesons only)
13034       IF ((IJPROJ.NE.0).AND.(IBPROJ.EQ.0)) THEN
13035          UNOPRV = UNOM
13036       ELSE
13037          UNOPRV = UNON
13038       ENDIF
13039
13040 * (2) select parton x-values of interacting projectile nucleons
13041 *-----------------------------------------------------------------------
13042
13043       IXPV = 0
13044       IXPS = 0
13045
13046       DO 100 IPP=1,IP
13047 *   get interacting projectile nucleon as sampled by Glauber
13048          IF (JSSH(IPP).NE.0) THEN
13049             IXSTMP = IXPS
13050             IXVTMP = IXPV
13051    99       CONTINUE
13052             IXPS   = IXSTMP
13053             IXPV   = IXVTMP
13054 *     JIPP is the actual number of sea-pairs sampled for this nucleon
13055             JIPP   = MIN(JSSH(IPP)-1,NSMAX)
13056    41       CONTINUE
13057             XXSEA  = ZERO
13058             IF (JIPP.GT.0) THEN
13059                XSMAX = XXSEAM-2.0D0*DBLE(JIPP)*XSTHR
13060 *???
13061                IF (XSTHR.GE.XSMAX) THEN
13062                   JIPP = JIPP-1
13063                   GOTO 41
13064                ENDIF
13065
13066 *>>>get x-values of sea-quark pairs
13067                NSCOUN = 0
13068                PLW = 0.5D0
13069    40          CONTINUE
13070 *     accumulator for sea x-values
13071                XXSEA  = ZERO
13072                NSCOUN = NSCOUN+1
13073                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13074                IF (NSCOUN.GT.NSEA) THEN
13075 *     decrease the number of interactions after NSEA trials
13076                   JIPP   = JIPP-1
13077                   NSCOUN = 0
13078                ENDIF
13079                DO 70 ISQ=1,JIPP
13080 *     sea-quarks
13081                   IF (IPSQ(IXPS+1).LE.2) THEN
13082 **sr 8.4.98 (1/sqrt(x))
13083 C                    XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13084 C                    XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13085                      XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13086 **
13087                   ELSE
13088                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13089                         XPSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13090                      ELSE
13091 **sr 8.4.98 (1/sqrt(x))
13092 C                       XPSQI = DT_SAMPEX(XSTHR,XSMAX)
13093 C                       XPSQI = DT_SAMSQX(XSTHR,XSMAX)
13094                         XPSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13095 **
13096                      ENDIF
13097                   ENDIF
13098 *     sea-antiquarks
13099                   IF (IPSAQ(IXPS+1).GE.-2) THEN
13100 **sr 8.4.98 (1/sqrt(x))
13101 C                    XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13102 C                    XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13103                      XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13104 **
13105                   ELSE
13106                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13107                         XPSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13108                      ELSE
13109 **sr 8.4.98 (1/sqrt(x))
13110 C                       XPSAQI = DT_SAMPEX(XSTHR,XSMAX)
13111 C                       XPSAQI = DT_SAMSQX(XSTHR,XSMAX)
13112                         XPSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13113 **
13114                      ENDIF
13115                   ENDIF
13116                   XXSEA = XXSEA+XPSQI+XPSAQI
13117 *     check for maximum allowed sea x-value
13118                   IF (XXSEA.GE.XXSEAM) THEN
13119                      IXPS = IXPS-ISQ+1
13120                      GOTO 40
13121                   ENDIF
13122 *     accept this sea-quark pair
13123                   IXPS         = IXPS+1
13124                   XPSQ(IXPS)   = XPSQI
13125                   XPSAQ(IXPS)  = XPSAQI
13126                   IFROSP(IXPS) = IPP
13127                   ZUOSP(IXPS)  = .TRUE.
13128    70          CONTINUE
13129             ENDIF
13130
13131 *>>>get x-values of valence partons
13132 *     valence quark
13133             IF (XVTHR.GT.0.05D0) THEN
13134                XVHI  = ONE-XXSEA-XDTHR
13135                XPVQI = DT_BETREJ(OHALF,UNOPRV,XVTHR,XVHI)
13136             ELSE
13137    90          CONTINUE
13138                XPVQI = DT_DBETAR(OHALF,UNOPRV)
13139                IF ((XPVQI.LT.XVTHR).OR.(ONE-XPVQI-XXSEA.LT.XDTHR))
13140      &                                                     GOTO 90
13141             ENDIF
13142 *     valence diquark
13143             XPVDI = ONE-XPVQI-XXSEA
13144 *       reject according to x**1.5
13145             XDTMP = XPVDI**1.5D0
13146             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 99
13147 *     accept these valence partons
13148             IXPV         = IXPV+1
13149             XPVQ(IXPV)   = XPVQI
13150             XPVD(IXPV)   = XPVDI
13151             IFROVP(IXPV) = IPP
13152             ITOVP(IPP)   = IXPV
13153             ZUOVP(IXPV)  = .TRUE.
13154
13155          ENDIF
13156   100 CONTINUE
13157
13158 * (3) select parton x-values of interacting target nucleons
13159 *-----------------------------------------------------------------------
13160
13161       IXTV = 0
13162       IXTS = 0
13163
13164       DO 170 ITT=1,IT
13165 *   get interacting target nucleon as sampled by Glauber
13166          IF (JTSH(ITT).NE.0) THEN
13167             IXSTMP = IXTS
13168             IXVTMP = IXTV
13169   169       CONTINUE
13170             IXTS   = IXSTMP
13171             IXTV   = IXVTMP
13172 *     JITT is the actual number of sea-pairs sampled for this nucleon
13173             JITT   = MIN(JTSH(ITT)-1,NSMAX)
13174   111       CONTINUE
13175             XXSEA  = ZERO
13176             IF (JITT.GT.0) THEN
13177                XSMAX = XXSEAM-2.0D0*DBLE(JITT)*XSTHR
13178 *???
13179                IF (XSTHR.GE.XSMAX) THEN
13180                   JITT = JITT-1
13181                   GOTO 111
13182                ENDIF
13183
13184 *>>>get x-values of sea-quark pairs
13185                NSCOUN = 0
13186                PLW = 0.5D0
13187   110          CONTINUE
13188 *     accumulator for sea x-values
13189                XXSEA  = ZERO
13190                NSCOUN = NSCOUN+1
13191                IF (DBLE(NSCOUN)/DBLE(NSEA).GT.0.5D0) PLW = 1.0D0
13192                IF (NSCOUN.GT.NSEA)THEN
13193 *     decrease the number of interactions after NSEA trials
13194                   JITT   = JITT-1
13195                   NSCOUN = 0
13196                ENDIF
13197                DO 140 ISQ=1,JITT
13198 *     sea-quarks
13199                   IF (ITSQ(IXTS+1).LE.2) THEN
13200 **sr 8.4.98 (1/sqrt(x))
13201 C                    XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13202 C                    XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13203                      XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13204 **
13205                   ELSE
13206                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13207                         XTSQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13208                      ELSE
13209 **sr 8.4.98 (1/sqrt(x))
13210 C                       XTSQI = DT_SAMPEX(XSTHR,XSMAX)
13211 C                       XTSQI = DT_SAMSQX(XSTHR,XSMAX)
13212                         XTSQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13213 **
13214                      ENDIF
13215                   ENDIF
13216 *     sea-antiquarks
13217                   IF (ITSAQ(IXTS+1).GE.-2) THEN
13218 **sr 8.4.98 (1/sqrt(x))
13219 C                    XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13220 C                    XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13221                      XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13222 **
13223                   ELSE
13224                      IF (XSMAX.GT.XSTHR+BSQMA) THEN
13225                         XTSAQI = DT_SAMPXB(XSTHR+BSQMA,XSMAX,BSQMA)
13226                      ELSE
13227 **sr 8.4.98 (1/sqrt(x))
13228 C                       XTSAQI = DT_SAMPEX(XSTHR,XSMAX)
13229 C                       XTSAQI = DT_SAMSQX(XSTHR,XSMAX)
13230                         XTSAQI = DT_SAMPLW(XSTHR,XSMAX,PLW)
13231 **
13232                      ENDIF
13233                   ENDIF
13234                   XXSEA = XXSEA+XTSQI+XTSAQI
13235 *     check for maximum allowed sea x-value
13236                   IF (XXSEA.GE.XXSEAM) THEN
13237                      IXTS = IXTS-ISQ+1
13238                      GOTO 110
13239                   ENDIF
13240 *     accept this sea-quark pair
13241                   IXTS         = IXTS+1
13242                   XTSQ(IXTS)   = XTSQI
13243                   XTSAQ(IXTS)  = XTSAQI
13244                   IFROST(IXTS) = ITT
13245                   ZUOST(IXTS)  = .TRUE.
13246   140          CONTINUE
13247             ENDIF
13248
13249 *>>>get x-values of valence partons
13250 *     valence quark
13251             IF (XVTHR.GT.0.05D0) THEN
13252                XVHI  = ONE-XXSEA-XDTHR
13253                XTVQI = DT_BETREJ(OHALF,UNON,XVTHR,XVHI)
13254             ELSE
13255   160          CONTINUE
13256                XTVQI = DT_DBETAR(OHALF,UNON)
13257                IF ((XTVQI.LT.XVTHR).OR.(ONE-XTVQI-XXSEA.LT.XDTHR))
13258      &                                                    GOTO 160
13259             ENDIF
13260 *     valence diquark
13261             XTVDI = ONE-XTVQI-XXSEA
13262 *       reject according to x**1.5
13263             XDTMP = XTVDI**1.5D0
13264             IF (DT_RNDM(XPVDI).GT.XDTMP) GOTO 169
13265 *     accept these valence partons
13266             IXTV         = IXTV+1
13267             XTVQ(IXTV)   = XTVQI
13268             XTVD(IXTV)   = XTVDI
13269             IFROVT(IXTV) = ITT
13270             ITOVT(ITT)   = IXTV
13271             ZUOVT(IXTV)  = .TRUE.
13272
13273          ENDIF
13274   170 CONTINUE
13275
13276 * (4) get valence-valence chains
13277 *-----------------------------------------------------------------------
13278
13279       NVV = 0
13280       DO 240 I=1,NN
13281          INTLO(I) = .TRUE.
13282          IPVAL    = ITOVP(INTER1(I))
13283          ITVAL    = ITOVT(INTER2(I))
13284          IF (ZUOVP(IPVAL).AND.ZUOVT(ITVAL)) THEN
13285             INTLO(I)      = .FALSE.
13286             ZUOVP(IPVAL)  = .FALSE.
13287             ZUOVT(ITVAL)  = .FALSE.
13288             NVV           = NVV+1
13289             ISKPCH(8,NVV) = 0
13290             INTVV1(NVV)   = IPVAL
13291             INTVV2(NVV)   = ITVAL
13292          ENDIF
13293   240 CONTINUE
13294
13295 * (5) get sea-valence chains
13296 *-----------------------------------------------------------------------
13297
13298       NSV = 0
13299       NDV = 0
13300       PLW = 0.5D0
13301       DO 270 I=1,NN
13302          IF (INTLO(I)) THEN
13303             IPVAL = ITOVP(INTER1(I))
13304             ITVAL = ITOVT(INTER2(I))
13305             DO 250 J=1,IXPS
13306                IF (ZUOSP(J).AND.(IFROSP(J).EQ.INTER1(I)).AND.
13307      &                                ZUOVT(ITVAL)) THEN
13308                   ZUOSP(J)     = .FALSE.
13309                   ZUOVT(ITVAL) = .FALSE.
13310                   INTLO(I)     = .FALSE.
13311                   IF (LSEADI.AND.(DT_RNDM(PLW).GT.FRCDIQ)) THEN
13312 *   sample sea-diquark pair
13313                      CALL DT_SAMSDQ(ECM,ITVAL,J,2,IREJ1)
13314                      IF (IREJ1.EQ.0) GOTO 260
13315                   ENDIF
13316                   NSV           = NSV+1
13317                   ISKPCH(4,NSV) = 0
13318                   INTSV1(NSV)   = J
13319                   INTSV2(NSV)   = ITVAL
13320
13321 *>>>correct chain kinematics according to minimum chain masses
13322 *     the actual chain masses
13323                   AMSVQ1 = XPSQ(J) *XTVD(ITVAL)*ECM**2
13324                   AMSVQ2 = XPSAQ(J)*XTVQ(ITVAL)*ECM**2
13325 *     get lower mass cuts
13326                   IF (IPSQ(J).EQ.3) THEN
13327 *       q being s-quark
13328                      AMCHK1 = AMAS
13329                      AMCHK2 = AMIS
13330                   ELSE
13331 *       q being u/d-quark
13332                      AMCHK1 = AMAU
13333                      AMCHK2 = AMIU
13334                   ENDIF
13335 *       q-qq chain
13336 *         chain mass above minimum - resampling of sea-q x-value
13337                   IF (AMSVQ1.GT.AMCHK1) THEN
13338                      XPSQTH      = AMCHK1/(XTVD(ITVAL)*ECM**2)
13339 **sr 8.4.98 (1/sqrt(x))
13340 C                    XPSQXX      = DT_SAMPEX(XPSQTH,XPSQ(J))
13341 C                    XPSQXX      = DT_SAMSQX(XPSQTH,XPSQ(J))
13342                      XPSQXX      = DT_SAMPLW(XPSQTH,XPSQ(J),PLW)
13343 **
13344                      XPVD(IPVAL) = XPVD(IPVAL)+XPSQ(J)-XPSQXX
13345                      XPSQ(J)     = XPSQXX
13346 *         chain mass below minimum - reset sea-q x-value and correct
13347 *                                    diquark-x of the same nucleon
13348                   ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13349                      XPSQW       = AMCHK1/(XTVD(ITVAL)*ECM**2)
13350                      DXPSQ       = XPSQW-XPSQ(J)
13351                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13352                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13353                         XPSQ(J)     = XPSQW
13354                      ENDIF
13355                   ENDIF
13356 *       aq-q chain
13357 *         chain mass below minimum - reset sea-aq x-value and correct
13358 *                                    diquark-x of the same nucleon
13359                   IF (AMSVQ2.LT.AMCHK2) THEN
13360                      XPSQW = AMCHK2/(XTVQ(ITVAL)*ECM**2)
13361                      DXPSQ = XPSQW-XPSAQ(J)
13362                      IF (XPVD(IPVAL).GE.XDTHR+DXPSQ) THEN
13363                         XPVD(IPVAL) = XPVD(IPVAL)-DXPSQ
13364                         XPSAQ(J)    = XPSQW
13365                      ENDIF
13366                   ENDIF
13367 *>>>end of chain mass correction
13368
13369                   GOTO 260
13370                ENDIF
13371   250       CONTINUE
13372          ENDIF
13373   260    CONTINUE
13374   270 CONTINUE
13375
13376 * (6) get valence-sea chains
13377 *-----------------------------------------------------------------------
13378
13379       NVS = 0
13380       NVD = 0
13381       DO 300 I=1,NN
13382          IF (INTLO(I)) THEN
13383             IPVAL = ITOVP(INTER1(I))
13384             ITVAL = ITOVT(INTER2(I))
13385             DO 280 J=1,IXTS
13386                IF (ZUOVP(IPVAL).AND.ZUOST(J).AND.
13387      &                  (IFROST(J).EQ.INTER2(I))) THEN
13388                   ZUOST(J)     = .FALSE.
13389                   ZUOVP(IPVAL) = .FALSE.
13390                   INTLO(I)     = .FALSE.
13391                   IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13392 *   sample sea-diquark pair
13393                      CALL DT_SAMSDQ(ECM,IPVAL,J,1,IREJ1)
13394                      IF (IREJ1.EQ.0) GOTO 290
13395                   ENDIF
13396                   NVS           = NVS + 1
13397                   ISKPCH(6,NVS) = 0
13398                   INTVS1(NVS)   = IPVAL
13399                   INTVS2(NVS)   = J
13400
13401 *>>>correct chain kinematics according to minimum chain masses
13402 *     the actual chain masses
13403                   AMVSQ1 = XPVQ(IPVAL)*XTSAQ(J)*ECM**2
13404                   AMVSQ2 = XPVD(IPVAL)*XTSQ(J) *ECM**2
13405 *     get lower mass cuts
13406                   IF (ITSQ(J).EQ.3) THEN
13407 *       q being s-quark
13408                      AMCHK1 = AMIS
13409                      AMCHK2 = AMAS
13410                   ELSE
13411 *       q being u/d-quark
13412                      AMCHK1 = AMIU
13413                      AMCHK2 = AMAU
13414                   ENDIF
13415 *       q-aq chain
13416 *         chain mass below minimum - reset sea-aq x-value and correct
13417 *                                    diquark-x of the same nucleon
13418                   IF (AMVSQ1.LT.AMCHK1) THEN
13419                      XTSQW = AMCHK1/(XPVQ(IPVAL)*ECM**2)
13420                      DXTSQ = XTSQW-XTSAQ(J)
13421                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13422                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13423                         XTSAQ(J)    = XTSQW
13424                      ENDIF
13425                   ENDIF
13426 *       qq-q chain
13427 *         chain mass above minimum - resampling of sea-q x-value
13428                   IF (AMVSQ2.GT.AMCHK2) THEN
13429                      XTSQTH      = AMCHK2/(XPVD(IPVAL)*ECM**2)
13430 **sr 8.4.98 (1/sqrt(x))
13431 C                    XTSQXX      = DT_SAMPEX(XTSQTH,XTSQ(J))
13432 C                    XTSQXX      = DT_SAMSQX(XTSQTH,XTSQ(J))
13433                      XTSQXX      = DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13434 **
13435                      XTVD(ITVAL) = XTVD(ITVAL)+XTSQ(J)-XTSQXX
13436                      XTSQ(J)     = XTSQXX
13437 *         chain mass below minimum - reset sea-q x-value and correct
13438 *                                    diquark-x of the same nucleon
13439                   ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13440                      XTSQW       = AMCHK2/(XPVD(IPVAL)*ECM**2)
13441                      DXTSQ       = XTSQW-XTSQ(J)
13442                      IF (XTVD(ITVAL).GE.XDTHR+DXTSQ) THEN
13443                         XTVD(ITVAL) = XTVD(ITVAL)-DXTSQ
13444                         XTSQ(J)     = XTSQW
13445                      ENDIF
13446                   ENDIF
13447 *>>>end of chain mass correction
13448
13449                   GOTO 290
13450                ENDIF
13451   280       CONTINUE
13452          ENDIF
13453   290    CONTINUE
13454   300 CONTINUE
13455
13456 * (7) get sea-sea chains
13457 *-----------------------------------------------------------------------
13458
13459       NSS = 0
13460       NDS = 0
13461       NSD = 0
13462       DO 420 I=1,NN
13463          IF (INTLO(I)) THEN
13464             IPVAL = ITOVP(INTER1(I))
13465             ITVAL = ITOVT(INTER2(I))
13466 *   loop over target partons not yet matched
13467             DO 400 J=1,IXTS
13468                IF (ZUOST(J).AND.(IFROST(J).EQ.INTER2(I))) THEN
13469 *   loop over projectile partons not yet matched
13470                   DO 390 JJ=1,IXPS
13471                      IF (ZUOSP(JJ).AND.(IFROSP(JJ).EQ.INTER1(I))) THEN
13472                         ZUOSP(JJ)     = .FALSE.
13473                         ZUOST(J)      = .FALSE.
13474                         INTLO(I)      = .FALSE.
13475                         NSS           = NSS+1
13476                         ISKPCH(1,NSS) = 0
13477                         INTSS1(NSS)   = JJ
13478                         INTSS2(NSS)   = J
13479
13480 *---->chain recombination option
13481                         VALFRA        = DBLE(NVV/(NVV+IXPS+IXTS))
13482                         IF (IRECOM.EQ.1.AND.(DT_RNDM(BSQMA).GT.VALFRA))
13483      &                                                             THEN
13484 *       sea-sea chains may recombine with valence-valence chains
13485 *       only if they have the same projectile or target nucleon
13486                            DO 4201 IVV=1,NVV
13487                               IF (ISKPCH(8,IVV).NE.99) THEN
13488                                  IXVPR = INTVV1(IVV)
13489                                  IXVTA = INTVV2(IVV)
13490                                  IF ((INTER1(I).EQ.IFROVP(IXVPR)).OR.
13491      &                               (INTER2(I).EQ.IFROVT(IXVTA))) THEN
13492 *         recombination possible, drop old v-v and s-s chains
13493                                     ISKPCH(1,NSS) = 99
13494                                     ISKPCH(8,IVV) = 99
13495
13496 *         (a) assign new s-v chains
13497 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
13498                                     IF (LSEADI.AND.
13499      &                                  (DT_RNDM(VALFRA).GT.FRCDIQ))
13500      &                                                             THEN
13501 *           sample sea-diquark pair
13502                                        CALL DT_SAMSDQ(ECM,IXVTA,JJ,2,
13503      &                                                      IREJ1)
13504                                        IF (IREJ1.EQ.0) GOTO 4202
13505                                     ENDIF
13506                                     NSV           = NSV+1
13507                                     ISKPCH(4,NSV) = 0
13508                                     INTSV1(NSV)   = JJ
13509                                     INTSV2(NSV)   = IXVTA
13510 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13511 *           the actual chain masses
13512                                     AMSVQ1 = XPSQ(JJ) *XTVD(IXVTA)
13513      &                                                     *ECM**2
13514                                     AMSVQ2 = XPSAQ(JJ)*XTVQ(IXVTA)
13515      &                                                     *ECM**2
13516 *           get lower mass cuts
13517                                     IF (IPSQ(JJ).EQ.3) THEN
13518 *             q being s-quark
13519                                        AMCHK1 = AMAS
13520                                        AMCHK2 = AMIS
13521                                     ELSE
13522 *             q being u/d-quark
13523                                        AMCHK1 = AMAU
13524                                        AMCHK2 = AMIU
13525                                     ENDIF
13526 *           q-qq chain
13527 *             chain mass above minimum - resampling of sea-q x-value
13528                                     IF (AMSVQ1.GT.AMCHK1) THEN
13529                                        XPSQTH      =
13530      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
13531 **sr 8.4.98 (1/sqrt(x))
13532                                        XPSQXX      =
13533      &                                    DT_SAMPLW(XPSQTH,XPSQ(JJ),PLW)
13534 C    &                                    DT_SAMSQX(XPSQTH,XPSQ(JJ))
13535 C    &                                    DT_SAMPEX(XPSQTH,XPSQ(JJ))
13536 **
13537                                        XPVD(IPVAL) =
13538      &                                    XPVD(IPVAL)+XPSQ(JJ)-XPSQXX
13539                                        XPSQ(JJ)    = XPSQXX
13540 *             chain mass below minimum - reset sea-q x-value and correct
13541 *                                        diquark-x of the same nucleon
13542                                     ELSEIF (AMSVQ1.LT.AMCHK1) THEN
13543                                        XPSQW =
13544      &                                    AMCHK1/(XTVD(IXVTA)*ECM**2)
13545                                        DXPSQ = XPSQW-XPSQ(JJ)
13546                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13547      &                                                            THEN
13548                                           XPVD(IPVAL) =
13549      &                                       XPVD(IPVAL)-DXPSQ
13550                                           XPSQ(JJ)    = XPSQW
13551                                        ENDIF
13552                                     ENDIF
13553 *           aq-q chain
13554 *             chain mass below minimum - reset sea-aq x-value and correct
13555 *                                        diquark-x of the same nucleon
13556                                     IF (AMSVQ2.LT.AMCHK2) THEN
13557                                        XPSQW =
13558      &                                    AMCHK2/(XTVQ(IXVTA)*ECM**2)
13559                                        DXPSQ = XPSQW-XPSAQ(JJ)
13560                                        IF (XPVD(IPVAL).GE.XDTHR+DXPSQ)
13561      &                                                            THEN
13562                                           XPVD(IPVAL) =
13563      &                                       XPVD(IPVAL)-DXPSQ
13564                                           XPSAQ(JJ)   = XPSQW
13565                                        ENDIF
13566                                     ENDIF
13567 *>>>>>>>>>>>end of chain mass correction
13568  4202                               CONTINUE
13569
13570 *         (b) assign new v-s chains
13571 *         ~~~~~~~~~~~~~~~~~~~~~~~~~
13572                                     IF (LSEADI.AND.(
13573      &                                  DT_RNDM(AMSVQ2).GT.FRCDIQ))
13574      &                                                             THEN
13575 *           sample sea-diquark pair
13576                                        CALL DT_SAMSDQ(ECM,IXVPR,J,1,
13577      &                                                      IREJ1)
13578                                        IF (IREJ1.EQ.0) GOTO 4203
13579                                     ENDIF
13580                                     NVS           = NVS+1
13581                                     ISKPCH(6,NVS) = 0
13582                                     INTVS1(NVS)   = IXVPR
13583                                     INTVS2(NVS)   = J
13584 *>>>>>>>>>>>correct chain kinematics according to minimum chain masses
13585 *           the actual chain masses
13586                                     AMVSQ1 = XPVQ(IXVPR)*XTSAQ(J)*ECM**2
13587                                     AMVSQ2 = XPVD(IXVPR)*XTSQ(J) *ECM**2
13588 *           get lower mass cuts
13589                                     IF (ITSQ(J).EQ.3) THEN
13590 *             q being s-quark
13591                                        AMCHK1 = AMIS
13592                                        AMCHK2 = AMAS
13593                                     ELSE
13594 *             q being u/d-quark
13595                                        AMCHK1 = AMIU
13596                                        AMCHK2 = AMAU
13597                                     ENDIF
13598 *           q-aq chain
13599 *             chain mass below minimum - reset sea-aq x-value and correct
13600 *                                        diquark-x of the same nucleon
13601                                     IF (AMVSQ1.LT.AMCHK1) THEN
13602                                        XTSQW =
13603      &                                    AMCHK1/(XPVQ(IXVPR)*ECM**2)
13604                                        DXTSQ = XTSQW-XTSAQ(J)
13605                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13606      &                                                            THEN
13607                                           XTVD(ITVAL) =
13608      &                                       XTVD(ITVAL)-DXTSQ
13609                                           XTSAQ(J)    = XTSQW
13610                                        ENDIF
13611                                     ENDIF
13612                                     IF (AMVSQ2.GT.AMCHK2) THEN
13613                                        XTSQTH      =
13614      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13615 **sr 8.4.98 (1/sqrt(x))
13616                                        XTSQXX      =
13617      &                                    DT_SAMPLW(XTSQTH,XTSQ(J),PLW)
13618 C    &                                    DT_SAMSQX(XTSQTH,XTSQ(J))
13619 C    &                                    DT_SAMPEX(XTSQTH,XTSQ(J))
13620 **
13621                                        XTVD(ITVAL) =
13622      &                                    XTVD(ITVAL)+XTSQ(J)-XTSQXX
13623                                        XTSQ(J)     = XTSQXX
13624                                     ELSEIF (AMVSQ2.LT.AMCHK2) THEN
13625                                        XTSQW =
13626      &                                    AMCHK2/(XPVD(IXVPR)*ECM**2)
13627                                        DXTSQ = XTSQW-XTSQ(J)
13628                                        IF (XTVD(ITVAL).GE.XDTHR+DXTSQ)
13629      &                                                            THEN
13630                                           XTVD(ITVAL) =
13631      &                                       XTVD(ITVAL)-DXTSQ
13632                                           XTSQ(J)     = XTSQW
13633                                        ENDIF
13634                                     ENDIF
13635 *>>>>>>>>>end of chain mass correction
13636  4203                               CONTINUE
13637 *       jump out of s-s chain loop
13638                                     GOTO 420
13639                                  ENDIF
13640                               ENDIF
13641  4201                      CONTINUE
13642                         ENDIF
13643 *---->end of chain recombination option
13644
13645 *     sample sea-diquark pair (projectile)
13646                         IF (LSEADI.AND.(DT_RNDM(BSQMA).GT.FRCDIQ)) THEN
13647                            CALL DT_SAMSDQ(ECM,J,JJ,4,IREJ1)
13648                            IF (IREJ1.EQ.0) THEN
13649                               ISKPCH(1,NSS) = 99
13650                               GOTO 410
13651                            ENDIF
13652                         ENDIF
13653 *     sample sea-diquark pair (target)
13654                         IF (LSEADI.AND.(DT_RNDM(ECM).GT.FRCDIQ)) THEN
13655                            CALL DT_SAMSDQ(ECM,JJ,J,3,IREJ1)
13656                            IF (IREJ1.EQ.0) THEN
13657                               ISKPCH(1,NSS) = 99
13658                               GOTO 410
13659                            ENDIF
13660                         ENDIF
13661 *>>>>>correct chain kinematics according to minimum chain masses
13662 *     the actual chain masses
13663                         SSMA1Q = XPSQ(JJ) *XTSAQ(J)*ECM**2
13664                         SSMA2Q = XPSAQ(JJ)*XTSQ(J) *ECM**2
13665 *     check for lower mass cuts
13666                         IF ((SSMA1Q.LT.SSMIMQ).OR.
13667      &                      (SSMA2Q.LT.SSMIMQ)) THEN
13668                            IPVAL = ITOVP(INTER1(I))
13669                            ITVAL = ITOVT(INTER2(I))
13670                            IF ((XPVD(IPVAL).GT.XDTHR+3.5D0*XSSTHR).AND.
13671      &                         (XTVD(ITVAL).GT.XDTHR+3.5D0*XSSTHR))THEN
13672 *       maximum allowed x values for sea quarks
13673                               XSPMAX = ONE-XPVQ(IPVAL)-XDTHR-
13674      &                                           1.2D0*XSSTHR
13675                               XSTMAX = ONE-XTVQ(ITVAL)-XDTHR-
13676      &                                           1.2D0*XSSTHR
13677 *       resampling of x values not possible - skip sea-sea chains
13678                               IF ((XSPMAX.LE.XSSTHR+0.05D0).OR.
13679      &                            (XSTMAX.LE.XSSTHR+0.05D0)) GOTO 380
13680 *       resampling of x for projectile sea quark pair
13681                               ICOUS = 0
13682   310                         CONTINUE
13683                               ICOUS = ICOUS+1
13684                               IF (XSSTHR.GT.0.05D0) THEN
13685                                  XPSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13686      &                                                         XSPMAX)
13687                                  XPSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13688      &                                                         XSPMAX)
13689                               ELSE
13690   320                            CONTINUE
13691                                  XPSQI = DT_DBETAR(XSEACU,UNOSEA)
13692                                  IF ((XPSQI.LT.XSSTHR).OR.
13693      &                               (XPSQI.GT.XSPMAX))  GOTO 320
13694   330                            CONTINUE
13695                                  XPSAQI = DT_DBETAR(XSEACU,UNOSEA)
13696                                  IF ((XPSAQI.LT.XSSTHR).OR.
13697      &                               (XPSAQI.GT.XSPMAX)) GOTO 330
13698                               ENDIF
13699 *       final test of remaining x for projectile diquark
13700                               XPVDCO = XPVD(IPVAL)-XPSQI-XPSAQI
13701      &                                            +XPSQ(JJ)+XPSAQ(JJ)
13702                               IF (XPVDCO.LE.XDTHR) THEN
13703 *!!!
13704 C                                IF (ICOUS.LT.5) GOTO 310
13705                                  IF (ICOUS.LT.0.5D0) GOTO 310
13706                                  GOTO 380
13707                               ENDIF
13708 *       resampling of x for target sea quark pair
13709                               ICOUS = 0
13710   350                         CONTINUE
13711                               ICOUS = ICOUS+1
13712                               IF (XSSTHR.GT.0.05D0) THEN
13713                                  XTSQI =DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13714      &                                                         XSTMAX)
13715                                  XTSAQI=DT_BETREJ(XSEACU,UNOSEA,XSSTHR,
13716      &                                                         XSTMAX)
13717                               ELSE
13718   360                            CONTINUE
13719                                  XTSQI = DT_DBETAR(XSEACU,UNOSEA)
13720                                  IF ((XTSQI.LT.XSSTHR).OR.
13721      &                               (XTSQI.GT.XSTMAX))  GOTO 360
13722   370                            CONTINUE
13723                                  XTSAQI = DT_DBETAR(XSEACU,UNOSEA)
13724                                  IF ((XTSAQI.LT.XSSTHR).OR.
13725      &                               (XTSAQI.GT.XSTMAX)) GOTO 370
13726                               ENDIF
13727 *       final test of remaining x for target diquark
13728                               XTVDCO = XTVD(ITVAL)-XTSQI-XTSAQI
13729      &                                            +XTSQ(J)+XTSAQ(J)
13730                               IF (XTVDCO.LT.XDTHR) THEN
13731                                  IF (ICOUS.LT.5) GOTO 350
13732                                  GOTO 380
13733                               ENDIF
13734                               XPVD(IPVAL) = XPVDCO
13735                               XTVD(ITVAL) = XTVDCO
13736                               XPSQ(JJ)    = XPSQI
13737                               XPSAQ(JJ)   = XPSAQI
13738                               XTSQ(J)     = XTSQI
13739                               XTSAQ(J)    = XTSAQI
13740 *>>>>>end of chain mass correction
13741                               GOTO 410
13742                            ENDIF
13743 *     come here to discard s-s interaction
13744 *     resampling of x values not allowed or unsuccessful
13745   380                      CONTINUE
13746                            INTLO(I)  = .FALSE.
13747                            ZUOST(J)  = .TRUE.
13748                            ZUOSP(JJ) = .TRUE.
13749                            NSS       = NSS-1
13750                         ENDIF
13751 *   consider next s-s interaction
13752                         GOTO 410
13753                      ENDIF
13754   390             CONTINUE
13755                ENDIF
13756   400       CONTINUE
13757          ENDIF
13758   410    CONTINUE
13759   420 CONTINUE
13760
13761 * correct x-values of valence quarks for non-matching sea quarks
13762       DO 430 I=1,IXPS
13763          IF (ZUOSP(I)) THEN
13764             IPVAL       = ITOVP(IFROSP(I))
13765             XPVQ(IPVAL) = XPVQ(IPVAL)+XPSQ(I)+XPSAQ(I)
13766             XPSQ(I)     = ZERO
13767             XPSAQ(I)    = ZERO
13768             ZUOSP(I)    = .FALSE.
13769          ENDIF
13770   430 CONTINUE
13771       DO 440 I=1,IXTS
13772          IF (ZUOST(I)) THEN
13773             ITVAL       = ITOVT(IFROST(I))
13774             XTVQ(ITVAL) = XTVQ(ITVAL)+XTSQ(I)+XTSAQ(I)
13775             XTSQ(I)     = ZERO
13776             XTSAQ(I)    = ZERO
13777             ZUOST(I)    = .FALSE.
13778          ENDIF
13779   440 CONTINUE
13780       DO 450 I=1,IXPV
13781          IF (ZUOVP(I)) ISTHKK(IFROVP(I)) = 13
13782   450 CONTINUE
13783       DO 460 I=1,IXTV
13784          IF (ZUOVT(I)) ISTHKK(IFROVT(I)+IP) = 14
13785   460 CONTINUE
13786
13787       RETURN
13788       END
13789
13790 *$ CREATE DT_SAMSDQ.FOR
13791 *COPY DT_SAMSDQ
13792 *
13793 *===samsdq=============================================================*
13794 *
13795       SUBROUTINE DT_SAMSDQ(ECM,IDX1,IDX2,MODE,IREJ)
13796
13797 ************************************************************************
13798 * SAMpling of Sea-DiQuarks                                             *
13799 *              ECM        cm-energy of the nucleon-nucleon system      *
13800 *              IDX1,2     indices of x-values of the participating     *
13801 *                         partons (IDX2 is always the sea-q-pair to be *
13802 *                         changed to sea-qq-pair)                      *
13803 *              MODE       = 1  valence-q - sea-diq                     *
13804 *                         = 2  sea-diq   - valence-q                   *
13805 *                         = 3  sea-q     - sea-diq                     *
13806 *                         = 4  sea-diq   - sea-q                       *
13807 * Based on DIQVS, DIQSV, DIQSSD, DIQDSS.                               *
13808 * This version dated 17.10.95 is written by S. Roesler                 *
13809 ************************************************************************
13810
13811       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
13812       SAVE
13813
13814       PARAMETER (ZERO=0.0D0)
13815
13816 * threshold values for x-sampling (DTUNUC 1.x)
13817       COMMON /DTXCUT/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
13818      &                SSMIMQ,VVMTHR
13819
13820 * various options for treatment of partons (DTUNUC 1.x)
13821 * (chain recombination, Cronin,..)
13822       LOGICAL LCO2CR,LINTPT
13823       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
13824      &                LCO2CR,LINTPT
13825
13826       PARAMETER ( MAXNCL = 260,
13827
13828      &            MAXVQU = MAXNCL,
13829      &            MAXSQU = 20*MAXVQU,
13830      &            MAXINT = MAXVQU+MAXSQU)
13831
13832 * x-values of partons (DTUNUC 1.x)
13833       COMMON /DTDPMX/ XPVQ(MAXVQU),XPVD(MAXVQU),
13834      &                XTVQ(MAXVQU),XTVD(MAXVQU),
13835      &                XPSQ(MAXSQU),XPSAQ(MAXSQU),
13836      &                XTSQ(MAXSQU),XTSAQ(MAXSQU)
13837
13838 * flavors of partons (DTUNUC 1.x)
13839       COMMON /DTDPMF/ IPVQ(MAXVQU),IPPV1(MAXVQU),IPPV2(MAXVQU),
13840      &                ITVQ(MAXVQU),ITTV1(MAXVQU),ITTV2(MAXVQU),
13841      &                IPSQ(MAXSQU),IPSQ2(MAXSQU),
13842      &                IPSAQ(MAXSQU),IPSAQ2(MAXSQU),
13843      &                ITSQ(MAXSQU),ITSQ2(MAXSQU),
13844      &                ITSAQ(MAXSQU),ITSAQ2(MAXSQU),
13845      &                KKPROJ(MAXVQU),KKTARG(MAXVQU)
13846
13847 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13848       COMMON /DTDPMI/ NVV,NSV,NVS,NSS,NDV,NVD,NDS,NSD,
13849      &                IXPV,IXPS,IXTV,IXTS,
13850      &                INTVV1(MAXVQU),INTVV2(MAXVQU),
13851      &                INTSV1(MAXVQU),INTSV2(MAXVQU),
13852      &                INTVS1(MAXVQU),INTVS2(MAXVQU),
13853      &                INTSS1(MAXSQU),INTSS2(MAXSQU),
13854      &                INTDV1(MAXVQU),INTDV2(MAXVQU),
13855      &                INTVD1(MAXVQU),INTVD2(MAXVQU),
13856      &                INTDS1(MAXSQU),INTDS2(MAXSQU),
13857      &                INTSD1(MAXSQU),INTSD2(MAXSQU)
13858
13859 * auxiliary common for x-value and flavor storage of partons (DTUNUC 1.x)
13860       COMMON /DTDPM0/ IFROVP(MAXVQU),ITOVP(MAXVQU),IFROSP(MAXSQU),
13861      &                IFROVT(MAXVQU),ITOVT(MAXVQU),IFROST(MAXSQU)
13862
13863 * auxiliary common for chain system storage (DTUNUC 1.x)
13864       COMMON /DTCHSY/ ISKPCH(8,MAXINT),IPOSP(MAXNCL),IPOST(MAXNCL)
13865
13866       IREJ = 0
13867 *  threshold-x for valence diquarks
13868       XDTHR = CDQ/ECM
13869
13870       GOTO (1,2,3,4) MODE
13871
13872 *---------------------------------------------------------------------
13873 * proj. valence partons - targ. sea partons
13874 * get x-values and flavors for target sea-diquark pair
13875
13876     1 CONTINUE
13877       IDXVP = IDX1
13878       IDXST = IDX2
13879
13880 *  index of corr. val-diquark-x in target nucleon
13881       IDXVT = ITOVT(IFROST(IDXST))
13882 *  available x above diquark thresholds for valence- and sea-diquarks
13883       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13884
13885       IF (XXD.GE.ZERO) THEN
13886 *  x-values for the three diquarks of the target nucleon
13887          RR1    = DT_RNDM(XXD)
13888          RR2    = DT_RNDM(RR1)
13889          RR3    = DT_RNDM(RR2)
13890          SR123  = RR1+RR2+RR3
13891          XXTV   = XDTHR+RR1*XXD/SR123
13892          XXTSQ  = XDTHR+RR2*XXD/SR123
13893          XXTSAQ = XDTHR+RR3*XXD/SR123
13894       ELSE
13895          XXTV   = XTVD(IDXVT)
13896          XXTSQ  = XTSQ(IDXST)
13897          XXTSAQ = XTSAQ(IDXST)
13898       ENDIF
13899 *  flavor of the second quarks in the sea-diquark pair
13900       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
13901       ITSAQ2(IDXST) = -ITSQ2(IDXST)
13902 *  check masses of the new val-q - sea-qq, val-qq - sea-aqaq chains
13903       AM1    = XXTSQ *XPVQ(IDXVP)*ECM**2
13904       AM2    = XXTSAQ*XPVD(IDXVP)*ECM**2
13905       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
13906 *    ss-asas pair
13907      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13908          IREJ = 1
13909          RETURN
13910       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
13911 *    at least one strange quark
13912      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13913          IREJ = 1
13914          RETURN
13915       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13916          IREJ = 1
13917          RETURN
13918       ENDIF
13919 *  accept the new sea-diquark
13920       XTVD(IDXVT)   = XXTV
13921       XTSQ(IDXST)   = XXTSQ
13922       XTSAQ(IDXST)  = XXTSAQ
13923       NVD           = NVD+1
13924       INTVD1(NVD)   = IDXVP
13925       INTVD2(NVD)   = IDXST
13926       ISKPCH(7,NVD) = 0
13927       RETURN
13928
13929 *---------------------------------------------------------------------
13930 * proj. sea partons - targ. valence partons
13931 * get x-values and flavors for projectile sea-diquark pair
13932
13933     2 CONTINUE
13934       IDXSP = IDX2
13935       IDXVT = IDX1
13936
13937 *  index of corr. val-diquark-x in projectile nucleon
13938       IDXVP = ITOVP(IFROSP(IDXSP))
13939 *  available x above diquark thresholds for valence- and sea-diquarks
13940       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
13941
13942       IF (XXD.GE.ZERO) THEN
13943 *  x-values for the three diquarks of the projectile nucleon
13944          RR1    = DT_RNDM(XXD)
13945          RR2    = DT_RNDM(RR1)
13946          RR3    = DT_RNDM(RR2)
13947          SR123  = RR1+RR2+RR3
13948          XXPV   = XDTHR+RR1*XXD/SR123
13949          XXPSQ  = XDTHR+RR2*XXD/SR123
13950          XXPSAQ = XDTHR+RR3*XXD/SR123
13951       ELSE
13952          XXPV   = XPVD(IDXVP)
13953          XXPSQ  = XPSQ(IDXSP)
13954          XXPSAQ = XPSAQ(IDXSP)
13955       ENDIF
13956 *  flavor of the second quarks in the sea-diquark pair
13957       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
13958       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
13959 *  check masses of the new sea-qq - val-q, sea-aqaq - val-qq chains
13960       AM1    = XXPSQ *XTVQ(IDXVT)*ECM**2
13961       AM2    = XXPSAQ*XTVD(IDXVT)*ECM**2
13962       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
13963 *    ss-asas pair
13964      &     ((AM2.LE.18.0D0).OR.(AM1.LE.6.6D0))            ) THEN
13965          IREJ = 1
13966          RETURN
13967       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
13968 *    at least one strange quark
13969      &         ((AM2.LE.14.6D0).OR.(AM1.LE.5.8D0))        ) THEN
13970          IREJ = 1
13971          RETURN
13972       ELSEIF ( (AM2.LE.13.4D0).OR.(AM1.LE.5.0D0) ) THEN
13973          IREJ = 1
13974          RETURN
13975       ENDIF
13976 *  accept the new sea-diquark
13977       XPVD(IDXVP)   = XXPV
13978       XPSQ(IDXSP)   = XXPSQ
13979       XPSAQ(IDXSP)  = XXPSAQ
13980       NDV           = NDV+1
13981       INTDV1(NDV)   = IDXSP
13982       INTDV2(NDV)   = IDXVT
13983       ISKPCH(5,NDV) = 0
13984       RETURN
13985
13986 *---------------------------------------------------------------------
13987 * proj. sea partons - targ. sea partons
13988 * get x-values and flavors for target sea-diquark pair
13989
13990     3 CONTINUE
13991       IDXSP = IDX1
13992       IDXST = IDX2
13993
13994 *  index of corr. val-diquark-x in target nucleon
13995       IDXVT = ITOVT(IFROST(IDXST))
13996 *  available x above diquark thresholds for valence- and sea-diquarks
13997       XXD   = XTVD(IDXVT)+XTSQ(IDXST)+XTSAQ(IDXST)-3.0D0*XDTHR
13998
13999       IF (XXD.GE.ZERO) THEN
14000 *  x-values for the three diquarks of the target nucleon
14001          RR1    = DT_RNDM(XXD)
14002          RR2    = DT_RNDM(RR1)
14003          RR3    = DT_RNDM(RR2)
14004          SR123  = RR1+RR2+RR3
14005          XXTV   = XDTHR+RR1*XXD/SR123
14006          XXTSQ  = XDTHR+RR2*XXD/SR123
14007          XXTSAQ = XDTHR+RR3*XXD/SR123
14008       ELSE
14009          XXTV   = XTVD(IDXVT)
14010          XXTSQ  = XTSQ(IDXST)
14011          XXTSAQ = XTSAQ(IDXST)
14012       ENDIF
14013 *  flavor of the second quarks in the sea-diquark pair
14014       ITSQ2(IDXST)  = INT(1.0D0+DT_RNDM(XXD)*(2.0D0+SEASQ))
14015       ITSAQ2(IDXST) = -ITSQ2(IDXST)
14016 *  check masses of the new sea-q - sea-qq, sea-aq - sea-aqaq chains
14017       AM1    = XXTSQ *XPSQ(IDXSP)*ECM**2
14018       AM2    = XXTSAQ*XPSAQ(IDXSP)*ECM**2
14019       IF ( (ITSQ(IDXST).EQ.3).AND.(ITSQ2(IDXST).EQ.3).AND.
14020 *    ss-asas pair
14021      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
14022          IREJ = 1
14023          RETURN
14024       ELSEIF ( ((ITSQ(IDXST).EQ.3).OR.(ITSQ2(IDXST).EQ.3)).AND.
14025 *    at least one strange quark
14026      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
14027          IREJ = 1
14028          RETURN
14029       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14030          IREJ = 1
14031          RETURN
14032       ENDIF
14033 *  accept the new sea-diquark
14034       XTVD(IDXVT)   = XXTV
14035       XTSQ(IDXST)   = XXTSQ
14036       XTSAQ(IDXST)  = XXTSAQ
14037       NSD           = NSD+1
14038       INTSD1(NSD)   = IDXSP
14039       INTSD2(NSD)   = IDXST
14040       ISKPCH(3,NSD) = 0
14041       RETURN
14042
14043 *---------------------------------------------------------------------
14044 * proj. sea partons - targ. sea partons
14045 * get x-values and flavors for projectile sea-diquark pair
14046
14047     4 CONTINUE
14048       IDXSP = IDX2
14049       IDXST = IDX1
14050
14051 *  index of corr. val-diquark-x in projectile nucleon
14052       IDXVP = ITOVP(IFROSP(IDXSP))
14053 *  available x above diquark thresholds for valence- and sea-diquarks
14054       XXD   = XPVD(IDXVP)+XPSQ(IDXSP)+XPSAQ(IDXSP)-3.0D0*XDTHR
14055
14056       IF (XXD.GE.ZERO) THEN
14057 *  x-values for the three diquarks of the projectile nucleon
14058          RR1    = DT_RNDM(XXD)
14059          RR2    = DT_RNDM(RR1)
14060          RR3    = DT_RNDM(RR2)
14061          SR123  = RR1+RR2+RR3
14062          XXPV   = XDTHR+RR1*XXD/SR123
14063          XXPSQ  = XDTHR+RR2*XXD/SR123
14064          XXPSAQ = XDTHR+RR3*XXD/SR123
14065       ELSE
14066          XXPV   = XPVD(IDXVP)
14067          XXPSQ  = XPSQ(IDXSP)
14068          XXPSAQ = XPSAQ(IDXSP)
14069       ENDIF
14070 *  flavor of the second quarks in the sea-diquark pair
14071       IPSQ2(IDXSP)  = INT(1.0D0+DT_RNDM(RR3)*(2.0D0+SEASQ))
14072       IPSAQ2(IDXSP) = -IPSQ2(IDXSP)
14073 *  check masses of the new sea-qq - sea-q, sea-aqaq - sea-qq chains
14074       AM1    = XXPSQ *XTSQ(IDXST)*ECM**2
14075       AM2    = XXPSAQ*XTSAQ(IDXST)*ECM**2
14076       IF ( (IPSQ(IDXSP).EQ.3).AND.(IPSQ2(IDXSP).EQ.3).AND.
14077 *    ss-asas pair
14078      &     ((AM2.LE.6.6D0).OR.(AM1.LE.6.6D0))            ) THEN
14079          IREJ = 1
14080          RETURN
14081       ELSEIF ( ((IPSQ(IDXSP).EQ.3).OR.(IPSQ2(IDXSP).EQ.3)).AND.
14082 *    at least one strange quark
14083      &         ((AM2.LE.5.8D0).OR.(AM1.LE.5.8D0))        ) THEN
14084          IREJ = 1
14085          RETURN
14086       ELSEIF ( (AM2.LE.5.0D0).OR.(AM1.LE.5.0D0) ) THEN
14087          IREJ = 1
14088          RETURN
14089       ENDIF
14090 *  accept the new sea-diquark
14091       XPVD(IDXVP)   = XXPV
14092       XPSQ(IDXSP)   = XXPSQ
14093       XPSAQ(IDXSP)  = XXPSAQ
14094       NDS           = NDS+1
14095       INTDS1(NDS)   = IDXSP
14096       INTDS2(NDS)   = IDXST
14097       ISKPCH(2,NDS) = 0
14098       RETURN
14099       END
14100 *$ CREATE DT_DIFEVT.FOR
14101 *COPY DT_DIFEVT
14102 *
14103 *===difevt=============================================================*
14104 *
14105       SUBROUTINE DT_DIFEVT(IFP1,IFP2,PP,MOP,
14106      &                  IFT1,IFT2,PT,MOT,JDIFF,NCSY,IREJ)
14107
14108 ************************************************************************
14109 * Interface to treatment of diffractive interactions.                  *
14110 *  (input)          IFP1/2        PDG-indizes of projectile partons    *
14111 *                                 (baryon: IFP2 - adiquark)            *
14112 *                   PP(4)         projectile 4-momentum                *
14113 *                   IFT1/2        PDG-indizes of target partons        *
14114 *                                 (baryon: IFT1 - adiquark)            *
14115 *                   PT(4)         target 4-momentum                    *
14116 *  (output)         JDIFF = 0     no diffraction                       *
14117 *                         = 1/-1  LMSD/LMDD                            *
14118 *                         = 2/-2  HMSD/HMDD                            *
14119 *                   NCSY          counter for two-chain systems        *
14120 *                                 dumped to DTEVT1                     *
14121 * This version dated 14.02.95 is written by S. Roesler                 *
14122 ************************************************************************
14123
14124       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14125       SAVE
14126
14127       PARAMETER ( LINP = 10 ,
14128      &            LOUT = 6 ,
14129      &            LDAT = 9 )
14130
14131       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5,
14132      &           OHALF=0.5D0)
14133
14134 * event history
14135
14136       PARAMETER (NMXHKK=200000)
14137
14138       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
14139      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
14140      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
14141
14142 * extended event history
14143       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
14144      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
14145      &                IHIST(2,NMXHKK)
14146
14147 * flags for diffractive interactions (DTUNUC 1.x)
14148       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
14149
14150       DIMENSION PP(4),PT(4)
14151
14152       LOGICAL LFIRST
14153       DATA LFIRST /.TRUE./
14154
14155       IREJ   = 0
14156       JDIFF  = 0
14157       IFLAGD = JDIFF
14158
14159 * cm. energy
14160       XM = SQRT((PP(4)+PT(4))**2-(PP(1)+PT(1))**2-
14161      &          (PP(2)+PT(2))**2-(PP(3)+PT(3))**2)
14162 * identities of projectile hadron / target nucleon
14163       KPROJ = IDT_ICIHAD(IDHKK(MOP))
14164       KTARG = IDT_ICIHAD(IDHKK(MOT))
14165
14166 * single diffractive xsections
14167       CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM)
14168 * double diffractive xsections
14169 **!! no double diff yet
14170 C     CALL DT_SHNDIF(XM,KPROJ,KTARG,SDTOT,SDHM,DDTOT,DDHM)
14171       DDTOT = 0.0D0
14172       DDHM  = 0.0D0
14173 **!!
14174 * total inelastic xsection
14175 C     SIGIN  = DT_SHNTOT(KPROJ,KTARG,XM,ZERO)-DT_SHNELA(KPROJ,KTARG,XM)
14176       DUMZER = ZERO
14177       CALL DT_XSHN(KPROJ,KTARG,DUMZER,XM,SIGTO,SIGEL)
14178       SIGIN  = MAX(SIGTO-SIGEL,ZERO)
14179
14180 * fraction of diffractive processes
14181       FRADIF = (SDTOT+DDTOT)/SIGIN
14182
14183       IF (LFIRST) THEN
14184          WRITE(LOUT,1000) XM,SDTOT,SIGIN
14185  1000    FORMAT(1X,'DIFEVT: single diffraction requested at E_cm = ',
14186      &          F5.1,' GeV',/,9X,'sigma_sd = ',F4.1,' mb, sigma_in = ',
14187      &          F5.1,' mb',/)
14188          LFIRST = .FALSE.
14189       ENDIF
14190
14191       IF ((DT_RNDM(DDHM).LE.FRADIF).OR.
14192      &    (ISINGD.GT.1).OR.(IDOUBD.GT.1)) THEN
14193 * diffractive interaction requested by x-section or by user
14194          FRASD  = SDTOT/(SDTOT+DDTOT)
14195          FRASDH = SDHM/SDTOT
14196 **sr needs to be specified!!
14197 C        FRADDH = DDHM/DDTOT
14198          FRADDH = 1.0D0
14199 **
14200          IF ((DT_RNDM(FRASD).LE.FRASD).OR.(ISINGD.GT.1)) THEN
14201 *   single diffraction
14202             KDIFF = 1
14203             IF (DT_RNDM(DDTOT).LE.FRASDH) THEN
14204                KP = 2
14205                KT = 0
14206                IF (((ISINGD.EQ.4).OR.(DT_RNDM(DDTOT).GE.OHALF)).AND.
14207      &               ISINGD.NE.3) THEN
14208                   KP = 0
14209                   KT = 2
14210                ENDIF
14211             ELSE
14212                KP = 1
14213                KT = 0
14214                IF (((ISINGD.EQ.4).OR.(DT_RNDM(FRADDH).GE.OHALF)).AND.
14215      &               ISINGD.NE.3) THEN
14216                   KP = 0
14217                   KT = 1
14218                ENDIF
14219             ENDIF
14220          ELSE
14221 *   double diffraction
14222             KDIFF = -1
14223             IF (DT_RNDM(FRADDH).LE.FRADDH) THEN
14224                KP = 2
14225                KT = 2
14226             ELSE
14227                KP = 1
14228                KT = 1
14229             ENDIF
14230          ENDIF
14231          CALL DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14232      &               IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14233          IF (IREJ1.EQ.0) THEN
14234             IFLAGD = 2*KDIFF
14235             IF ((KP.EQ.1).OR.(KT.EQ.1)) IFLAGD = KDIFF
14236          ELSE
14237             GOTO 9999
14238          ENDIF
14239       ENDIF
14240       JDIFF = IFLAGD
14241
14242       RETURN
14243
14244  9999 CONTINUE
14245       IREJ  = 1
14246       RETURN
14247       END
14248
14249 *$ CREATE DT_DIFFKI.FOR
14250 *COPY DT_DIFFKI
14251 *
14252 *===difkin=============================================================*
14253 *
14254       SUBROUTINE DT_DIFFKI(IFP1,IFP2,PP,MOP,KP,
14255      &                  IFT1,IFT2,PT,MOT,KT,NCSY,IREJ)
14256
14257 ************************************************************************
14258 * Kinematics of diffractive nucleon-nucleon interaction.               *
14259 *          IFP1/2   PDG-indizes of projectile partons                  *
14260 *                   (baryon: IFP2 - adiquark)                          *
14261 *          PP(4)    projectile 4-momentum                              *
14262 *          IFT1/2   PDG-indizes of target partons                      *
14263 *                   (baryon: IFT1 - adiquark)                          *
14264 *          PT(4)    target 4-momentum                                  *
14265 *          KP   = 0 projectile quasi-elastically scattered             *
14266 *               = 1            excited to low-mass diff. state         *
14267 *               = 2            excited to high-mass diff. state        *
14268 *          KT   = 0 target     quasi-elastically scattered             *
14269 *               = 1            excited to low-mass diff. state         *
14270 *               = 2            excited to high-mass diff. state        *
14271 * This version dated 12.02.95 is written by S. Roesler                 *
14272 ************************************************************************
14273
14274       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14275       SAVE
14276
14277       PARAMETER ( LINP = 10 ,
14278      &            LOUT = 6 ,
14279      &            LDAT = 9 )
14280
14281       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY10=1.0D-10,TINY5=1.0D-5)
14282
14283       LOGICAL LSTART
14284
14285 * particle properties (BAMJET index convention)
14286       CHARACTER*8  ANAME
14287       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
14288      &                IICH(210),IIBAR(210),K1(210),K2(210)
14289
14290 * flags for input different options
14291       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14292       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14293      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14294
14295 * rejection counter
14296       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
14297      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
14298      &                IREXCI(3),IRDIFF(2),IRINC
14299
14300 * kinematics of diffractive interactions (DTUNUC 1.x)
14301       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14302      &                PPF(4),PTF(4),
14303      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14304      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14305
14306       DIMENSION PITOT(4),BGTOT(4),PP1(4),PT1(4),PPBLOB(4),PTBLOB(4),
14307      &          PP(4),PT(4),PPOM1(4),DEV1(4),DEV2(4)
14308
14309       DATA LSTART /.TRUE./
14310
14311       IF (LSTART) THEN
14312          WRITE(LOUT,2000)
14313  2000    FORMAT(/,1X,'DIFEVT:  diffractive interactions treated ')
14314          LSTART = .FALSE.
14315       ENDIF
14316
14317       IREJ = 0
14318
14319 * initialize common /DTDIKI/
14320       CALL DT_DIFINI
14321 * store momenta of initial incoming particles for emc-check
14322       IF (LEMCCK) THEN
14323          CALL DT_EVTEMC(PP(1),PP(2),PP(3),PP(4),1,IDUM,IDUM)
14324          CALL DT_EVTEMC(PT(1),PT(2),PT(3),PT(4),2,IDUM,IDUM)
14325       ENDIF
14326
14327 * masses of initial particles
14328       XMP2 = PP(4)**2-PP(1)**2-PP(2)**2-PP(3)**2
14329       XMT2 = PT(4)**2-PT(1)**2-PT(2)**2-PT(3)**2
14330       IF ((XMP2.LT.ZERO).OR.(XMT2.LT.ZERO)) GOTO 9999
14331       XMP  = SQRT(XMP2)
14332       XMT  = SQRT(XMT2)
14333 * check quark-input (used to adjust coherence cond. for M-selection)
14334       IBP  = 0
14335       IF ((ABS(IFP1).GE.1000).OR.(ABS(IFP2).GE.1000)) IBP = 1
14336       IBT  = 0
14337       IF ((ABS(IFT1).GE.1000).OR.(ABS(IFT2).GE.1000)) IBT = 1
14338
14339 * parameter for Lorentz-transformation into nucleon-nucleon cms
14340       DO 3 K=1,4
14341          PITOT(K) = PP(K)+PT(K)
14342     3 CONTINUE
14343       XMTOT2 = PITOT(4)**2-PITOT(1)**2-PITOT(2)**2-PITOT(3)**2
14344       IF (XMTOT2.LE.ZERO) THEN
14345          WRITE(LOUT,1000) XMTOT2
14346  1000    FORMAT(1X,'DIFEVT:   negative cm. energy!  ',
14347      &          'XMTOT2 = ',E12.3)
14348          GOTO 9999
14349       ENDIF
14350       XMTOT = SQRT(XMTOT2)
14351       DO 4 K=1,4
14352          BGTOT(K) = PITOT(K)/XMTOT
14353     4 CONTINUE
14354 * transformation of nucleons into cms
14355       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PP(1),PP(2),
14356      &            PP(3),PP(4),PPTOT,PP1(1),PP1(2),PP1(3),PP1(4))
14357       CALL DT_DALTRA(BGTOT(4),-BGTOT(1),-BGTOT(2),-BGTOT(3),PT(1),PT(2),
14358      &            PT(3),PT(4),PTTOT,PT1(1),PT1(2),PT1(3),PT1(4))
14359 * rotation angles
14360       COD = PP1(3)/PPTOT
14361 C     SID = SQRT((ONE-COD)*(ONE+COD))
14362       PPT = SQRT(PP1(1)**2+PP1(2)**2)
14363       SID = PPT/PPTOT
14364       COF = ONE
14365       SIF = ZERO
14366       IF(PPTOT*SID.GT.TINY10) THEN
14367          COF   = PP1(1)/(SID*PPTOT)
14368          SIF   = PP1(2)/(SID*PPTOT)
14369          ANORF = SQRT(COF*COF+SIF*SIF)
14370          COF   = COF/ANORF
14371          SIF   = SIF/ANORF
14372       ENDIF
14373 * check consistency
14374       DO 5 K=1,4
14375          DEV1(K) = ABS(PP1(K)+PT1(K))
14376     5 CONTINUE
14377       DEV1(4) = ABS(DEV1(4)-XMTOT)
14378       IF ((DEV1(1).GT.TINY10).OR.(DEV1(2).GT.TINY10).OR.
14379      &    (DEV1(3).GT.TINY10).OR.(DEV1(4).GT.TINY10))     THEN
14380          WRITE(LOUT,1001) DEV1
14381  1001    FORMAT(1X,'DIFEVT:   inconsitent Lorentz-transformation! ',
14382      &          /,8X,4E12.3)
14383          GOTO 9999
14384       ENDIF
14385
14386 * select x-fractions in high-mass diff. interactions
14387       IF ((KP.EQ.2).OR.(KT.EQ.2)) CALL DT_XVALHM(KP,KT)
14388
14389 * select diffractive masses
14390 * - projectile
14391       IF (KP.EQ.1) THEN
14392          XMPF = DT_XMLMD(XMTOT)
14393          CALL DT_LM2RES(IFP1,IFP2,XMPF,IDPR,IDXPR,IREJ1)
14394          IF (IREJ1.GT.0) GOTO 9999
14395       ELSEIF (KP.EQ.2) THEN
14396          XMPF = DT_XMHMD(XMTOT,IBP,1)
14397       ELSE
14398          XMPF = XMP
14399       ENDIF
14400 * - target
14401       IF (KT.EQ.1) THEN
14402          XMTF = DT_XMLMD(XMTOT)
14403          CALL DT_LM2RES(IFT1,IFT2,XMTF,IDTR,IDXTR,IREJ1)
14404          IF (IREJ1.GT.0) GOTO 9999
14405       ELSEIF (KT.EQ.2) THEN
14406          XMTF = DT_XMHMD(XMTOT,IBT,2)
14407       ELSE
14408          XMTF = XMT
14409       ENDIF
14410
14411 * kinematical treatment of "two-particle" system (masses - XMPF,XMTF)
14412       XMPF2 = XMPF**2
14413       XMTF2 = XMTF**2
14414       PPBLOB(3) = DT_YLAMB(XMTOT2,XMPF2,XMTF2)/(2.D0*XMTOT)
14415       PPBLOB(4) = SQRT(XMPF2+PPBLOB(3)**2)
14416
14417 * select momentum transfer (all t-values used here are <0)
14418 *   minimum absolute value to produce diffractive masses
14419       TMIN = XMP2+XMPF2-2.0D0*(PP1(4)*PPBLOB(4)-PPTOT*PPBLOB(3))
14420       TT   = DT_TDIFF(XMTOT,TMIN,XMPF,KP,XMTF,KT,IREJ1)
14421       IF (IREJ1.GT.0) GOTO 9999
14422
14423 * longitudinal momentum of excited/elastically scattered projectile
14424       PPBLOB(3) = (TT-XMP2-XMPF2+2.0D0*PP1(4)*PPBLOB(4))/(2.0D0*PPTOT)
14425 * total transverse momentum due to t-selection
14426       PPBLT2 = PPBLOB(4)**2-PPBLOB(3)**2-XMPF2
14427       IF (PPBLT2.LT.ZERO) THEN
14428          WRITE(LOUT,1002) PPBLT2,KP,PP1,XMPF,KT,PT1,XMTF,TT
14429  1002    FORMAT(1X,'DIFEVT:   inconsistent transverse momentum! ',
14430      &          E12.3,2(/,1X,I2,5E12.3),/,1X,E12.3)
14431          GOTO 9999
14432       ENDIF
14433       CALL DT_DSFECF(SINPHI,COSPHI)
14434       PPBLT     = SQRT(PPBLT2)
14435       PPBLOB(1) = COSPHI*PPBLT
14436       PPBLOB(2) = SINPHI*PPBLT
14437
14438 * rotate excited/elastically scattered projectile into n-n cms.
14439       CALL DT_MYTRAN(1,PPBLOB(1),PPBLOB(2),PPBLOB(3),COD,SID,COF,SIF,
14440      &                                                    XX,YY,ZZ)
14441       PPBLOB(1) = XX
14442       PPBLOB(2) = YY
14443       PPBLOB(3) = ZZ
14444
14445 * 4-momentum of excited/elastically scattered target and of exchanged
14446 * Pomeron
14447       DO 6 K=1,4
14448          IF (K.LT.4) PTBLOB(K) = -PPBLOB(K)
14449          PPOM1(K) = PP1(K)-PPBLOB(K)
14450     6 CONTINUE
14451       PTBLOB(4) = XMTOT-PPBLOB(4)
14452
14453 * Lorentz-transformation back into system of initial diff. collision
14454       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14455      &            PPBLOB(1),PPBLOB(2),PPBLOB(3),PPBLOB(4),
14456      &            PPTOTF,PPF(1),PPF(2),PPF(3),PPF(4))
14457       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14458      &            PTBLOB(1),PTBLOB(2),PTBLOB(3),PTBLOB(4),
14459      &            PTTOTF,PTF(1),PTF(2),PTF(3),PTF(4))
14460       CALL DT_DALTRA(BGTOT(4),BGTOT(1),BGTOT(2),BGTOT(3),
14461      &            PPOM1(1),PPOM1(2),PPOM1(3),PPOM1(4),
14462      &            PPOMTO,PPOM(1),PPOM(2),PPOM(3),PPOM(4))
14463
14464 * store 4-momentum of elastically scattered particle (in single diff.
14465 * events)
14466       IF (KP.EQ.0) THEN
14467          DO 7 K=1,4
14468             PSC(K) = PPF(K)
14469     7    CONTINUE
14470       ELSEIF (KT.EQ.0) THEN
14471          DO 8 K=1,4
14472             PSC(K) = PTF(K)
14473     8    CONTINUE
14474       ENDIF
14475
14476 * check consistency of kinematical treatment so far
14477       IF (LEMCCK) THEN
14478          CALL DT_EVTEMC(-PPF(1),-PPF(2),-PPF(3),-PPF(4),2,IDUM,IDUM)
14479          CALL DT_EVTEMC(-PTF(1),-PTF(2),-PTF(3),-PTF(4),2,IDUM,IDUM)
14480          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,60,IREJ1)
14481          IF (IREJ1.NE.0) GOTO 9999
14482       ENDIF
14483       DO 9 K=1,4
14484          DEV1(K) = ABS(PP(K)-PPF(K)-PPOM(K))
14485          DEV2(K) = ABS(PT(K)-PTF(K)+PPOM(K))
14486     9 CONTINUE
14487       IF ((DEV1(1).GT.TINY5).OR.(DEV1(2).GT.TINY5).OR.
14488      &    (DEV1(3).GT.TINY5).OR.(DEV1(4).GT.TINY5).OR.
14489      &    (DEV2(1).GT.TINY5).OR.(DEV2(2).GT.TINY5).OR.
14490      &    (DEV2(3).GT.TINY5).OR.(DEV2(4).GT.TINY5))     THEN
14491          WRITE(LOUT,1003) DEV1,DEV2
14492  1003    FORMAT(1X,'DIFEVT:   inconsitent kinematical treatment!  ',
14493      &          2(/,8X,4E12.3))
14494          GOTO 9999
14495       ENDIF
14496
14497 * kinematical treatment for low-mass diffraction
14498       CALL DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ1)
14499       IF (IREJ1.NE.0) GOTO 9999
14500
14501 * dump diffractive chains into DTEVT1
14502       CALL DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,IREJ1)
14503       IF (IREJ1.NE.0) GOTO 9999
14504
14505       RETURN
14506
14507  9999 CONTINUE
14508       IRDIFF(1) = IRDIFF(1)+1
14509       IREJ      = 1
14510       RETURN
14511       END
14512
14513 *$ CREATE DT_XMHMD.FOR
14514 *COPY DT_XMHMD
14515 *
14516 *===xmhmd==============================================================*
14517 *
14518       DOUBLE PRECISION FUNCTION DT_XMHMD(ECM,IB,MODE)
14519
14520 ************************************************************************
14521 * Diffractive mass in high mass single/double diffractive events.      *
14522 * This version dated 11.02.95 is written by S. Roesler                 *
14523 ************************************************************************
14524
14525       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14526       SAVE
14527
14528       PARAMETER ( LINP = 10 ,
14529      &            LOUT = 6 ,
14530      &            LDAT = 9 )
14531
14532       PARAMETER (OHALF=0.5D0,ONE=1.0D0,ZERO=0.0D0)
14533
14534 * kinematics of diffractive interactions (DTUNUC 1.x)
14535       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14536      &                PPF(4),PTF(4),
14537      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14538      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14539
14540 C     DATA XCOLOW /0.05D0/
14541       DATA XCOLOW /0.15D0/
14542
14543       DT_XMHMD = ZERO
14544       XH = XPH(2)
14545       IF (MODE.EQ.2) XH = XTH(2)
14546
14547 * minimum Pomeron-x for high-mass diffraction
14548 * (adjusted to get a smooth transition between HM and LM component)
14549       R = DT_RNDM(XH)
14550       XDIMIN = (3.0D0+400.0D0*R**2)/(XH*ECM**2)
14551       IF (ECM.LE.300.0D0) THEN
14552          RR     = (1.0D0-EXP(-((ECM/140.0D0)**4)))
14553          XDIMIN = (3.0D0+400.0D0*(R**2)*RR)/(XH*ECM**2)
14554       ENDIF
14555 * maximum Pomeron-x for high-mass diffraction
14556 * (coherence condition, adjusted to fit to experimental data)
14557       IF (IB.NE.0) THEN
14558 *   baryon-diffraction
14559          XDIMAX = XCOLOW*(1.0D0+EXP(-((ECM/420.0D0)**2)))
14560       ELSE
14561 *   meson-diffraction
14562          XDIMAX = XCOLOW*(1.0D0+4.0D0*EXP(-((ECM/420.0D0)**2)))
14563       ENDIF
14564 * check boundaries
14565       IF (XDIMIN.GE.XDIMAX) THEN
14566          XDIMIN = OHALF*XDIMAX
14567       ENDIF
14568
14569       KLOOP = 0
14570     1 CONTINUE
14571       KLOOP = KLOOP+1
14572       IF (KLOOP.GT.20) RETURN
14573 * sample Pomeron-x from 1/x-distribution (critical Pomeron)
14574       XDIFF = DT_SAMPEX(XDIMIN,XDIMAX)
14575 * corr. diffr. mass
14576       DT_XMHMD = ECM*SQRT(XDIFF)
14577       IF (DT_XMHMD.LT.2.5D0) GOTO 1
14578
14579       RETURN
14580       END
14581
14582 *$ CREATE DT_XMLMD.FOR
14583 *COPY DT_XMLMD
14584 *
14585 *===xmlmd==============================================================*
14586 *
14587       DOUBLE PRECISION FUNCTION DT_XMLMD(ECM)
14588
14589 ************************************************************************
14590 * Diffractive mass in high mass single/double diffractive events.      *
14591 * This version dated 11.02.95 is written by S. Roesler                 *
14592 ************************************************************************
14593
14594       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14595       SAVE
14596
14597       PARAMETER ( LINP = 10 ,
14598      &            LOUT = 6 ,
14599      &            LDAT = 9 )
14600
14601 * minimum Pomeron-x for low-mass diffraction
14602 C     AMO = 1.5D0
14603       AMO = 2.0D0
14604 * maximum Pomeron-x for low-mass diffraction
14605 * (adjusted to get a smooth transition between HM and LM component)
14606       R   = DT_RNDM(AMO)
14607       SAM = 1.0D0
14608       IF (ECM.LE.300.0D0) SAM = 1.0D0-EXP(-((ECM/200.0D0)**4))
14609       R   = DT_RNDM(AMO)*SAM
14610       AMAX= (1.0D0-SAM)*SQRT(0.1D0*ECM**2)+SAM*SQRT(400.0D0)
14611       AMU = R*SQRT(100.0D0)+(1.0D0-R)*AMAX
14612
14613 * selection of diffractive mass
14614 * (adjusted to get a smooth transition between HM and LM component)
14615       R   = DT_RNDM(AMU)
14616       IF (ECM.LE.50.0D0) THEN
14617          DT_XMLMD = AMO*(AMU/AMO)**R
14618       ELSE
14619          A = 0.7D0
14620          IF (ECM.LE.300.0D0) A = 0.7D0*(1.0D0-EXP(-((ECM/100.0D0)**2)))
14621          DT_XMLMD = 1.0D0/((R/(AMU**A)+(1.0D0-R)/(AMO**A))**(1.0D0/A))
14622       ENDIF
14623
14624       RETURN
14625       END
14626
14627 *$ CREATE DT_TDIFF.FOR
14628 *COPY DT_TDIFF
14629 *
14630 *===tdiff==============================================================*
14631 *
14632       DOUBLE PRECISION FUNCTION DT_TDIFF(ECM,TMIN,XM1I,K1,XM2I,K2,IREJ)
14633
14634 ************************************************************************
14635 * t-selection for single/double diffractive interactions.              *
14636 *          ECM      cm. energy                                         *
14637 *          TMIN     minimum momentum transfer to produce diff. masses  *
14638 *          XM1/XM2  diffractively produced masses                      *
14639 *                   (for single diffraction XM2 is obsolete)           *
14640 *          K1/K2= 0 not excited                                        *
14641 *               = 1 low-mass excitation                                *
14642 *               = 2 high-mass excitation                               *
14643 * This version dated 11.02.95 is written by S. Roesler                 *
14644 ************************************************************************
14645
14646       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14647       SAVE
14648
14649       PARAMETER ( LINP = 10 ,
14650      &            LOUT = 6 ,
14651      &            LDAT = 9 )
14652
14653       PARAMETER (ZERO=0.0D0)
14654
14655       PARAMETER ( BTP0   = 3.7D0,
14656      &            ALPHAP = 0.24D0 )
14657
14658       IREJ   = 0
14659       NCLOOP = 0
14660       DT_TDIFF  = ZERO
14661
14662       IF (K1.GT.0) THEN
14663          XM1 = XM1I
14664          XM2 = XM2I
14665       ELSE
14666          XM1 = XM2I
14667       ENDIF
14668       XDI = (XM1/ECM)**2
14669       IF ((K1.EQ.0).OR.(K2.EQ.0)) THEN
14670 * slope for single diffraction
14671          SLOPE = BTP0-2.0D0*ALPHAP*LOG(XDI)
14672       ELSE
14673 * slope for double diffraction
14674          SLOPE = -2.0D0*ALPHAP*LOG(XDI*XM2**2)
14675       ENDIF
14676
14677     1 CONTINUE
14678       NCLOOP = NCLOOP+1
14679       IF (MOD(NCLOOP,1000).EQ.0) GOTO 9999
14680       Y = DT_RNDM(XDI)
14681       T = -LOG(1.0D0-Y)/SLOPE
14682       IF (ABS(T).LE.ABS(TMIN)) GOTO 1
14683       DT_TDIFF = -ABS(T)
14684
14685       RETURN
14686
14687  9999 CONTINUE
14688       WRITE(LOUT,1000) ECM,TMIN,XM1I,XM2I,K1,K2
14689  1000 FORMAT(1X,'DT_TDIFF:   t-selection rejected!',/,
14690      &       1X,'ECM  = ',E12.3,' TMIN = ',E12.2,/,1X,'XM1I = ',
14691      &       E12.3,' XM2I = ',E12.3,' K1 = ',I2,' K2 = ',I2)
14692       IREJ = 1
14693       RETURN
14694       END
14695
14696 *$ CREATE DT_XVALHM.FOR
14697 *COPY DT_XVALHM
14698 *
14699 *===xvalhm=============================================================*
14700 *
14701       SUBROUTINE DT_XVALHM(KP,KT)
14702
14703 ************************************************************************
14704 * Sampling of parton x-values in high-mass diffractive interactions.   *
14705 * This version dated 12.02.95 is written by S. Roesler                 *
14706 ************************************************************************
14707
14708       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14709       SAVE
14710
14711       PARAMETER ( LINP = 10 ,
14712      &            LOUT = 6 ,
14713      &            LDAT = 9 )
14714
14715       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0,TINY2=1.0D-2)
14716
14717 * kinematics of diffractive interactions (DTUNUC 1.x)
14718       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14719      &                PPF(4),PTF(4),
14720      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14721      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14722
14723 * various options for treatment of partons (DTUNUC 1.x)
14724 * (chain recombination, Cronin,..)
14725       LOGICAL LCO2CR,LINTPT
14726       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
14727      &                LCO2CR,LINTPT
14728
14729       DATA UNON,XVQTHR /2.0D0,0.8D0/
14730
14731       IF (KP.EQ.2) THEN
14732 * x-fractions of projectile valence partons
14733     1    CONTINUE
14734          XPH(1) = DT_DBETAR(OHALF,UNON)
14735          IF (XPH(1).GE.XVQTHR) GOTO 1
14736          XPH(2) = ONE-XPH(1)
14737 * x-fractions of Pomeron q-aq-pair
14738          XPOLO = TINY2
14739          XPOHI = ONE-TINY2
14740          XPPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14741          XPPO(2) = ONE-XPPO(1)
14742 * flavors of Pomeron q-aq-pair
14743          IFLAV    = INT(ONE+DT_RNDM(UNON)*(2.0D0+SEASQ))
14744          IFPPO(1) = IFLAV
14745          IFPPO(2) = -IFLAV
14746          IF (DT_RNDM(UNON).GT.OHALF) THEN
14747             IFPPO(1) = -IFLAV
14748             IFPPO(2) = IFLAV
14749          ENDIF
14750       ENDIF
14751
14752       IF (KT.EQ.2) THEN
14753 * x-fractions of projectile target partons
14754     2    CONTINUE
14755          XTH(1) = DT_DBETAR(OHALF,UNON)
14756          IF (XTH(1).GE.XVQTHR) GOTO 2
14757          XTH(2) = ONE-XTH(1)
14758 * x-fractions of Pomeron q-aq-pair
14759          XPOLO = TINY2
14760          XPOHI = ONE-TINY2
14761          XTPO(1) = DT_SAMPEX(XPOLO,XPOHI)
14762          XTPO(2) = ONE-XTPO(1)
14763 * flavors of Pomeron q-aq-pair
14764          IFLAV    = INT(ONE+DT_RNDM(XPOLO)*(2.0D0+SEASQ))
14765          IFTPO(1) = IFLAV
14766          IFTPO(2) = -IFLAV
14767          IF (DT_RNDM(XPOLO).GT.OHALF) THEN
14768             IFTPO(1) = -IFLAV
14769             IFTPO(2) = IFLAV
14770          ENDIF
14771       ENDIF
14772
14773       RETURN
14774       END
14775
14776 *$ CREATE DT_LM2RES.FOR
14777 *COPY DT_LM2RES
14778 *
14779 *===lm2res=============================================================*
14780 *
14781       SUBROUTINE DT_LM2RES(IF1,IF2,XM,IDR,IDXR,IREJ)
14782
14783 ************************************************************************
14784 * Check low-mass diffractive excitation for resonance mass.            *
14785 *   (input)   IF1/2    PDG-indizes of valence partons                  *
14786 *   (in/out)  XM       diffractive mass requested/corrected            *
14787 *   (output)  IDR/IDXR id./BAMJET-index of resonance                   *
14788 * This version dated 12.02.95 is written by S. Roesler                 *
14789 ************************************************************************
14790
14791       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14792       SAVE
14793
14794       PARAMETER ( LINP = 10 ,
14795      &            LOUT = 6 ,
14796      &            LDAT = 9 )
14797
14798       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14799
14800 * kinematics of diffractive interactions (DTUNUC 1.x)
14801       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14802      &                PPF(4),PTF(4),
14803      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14804      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14805
14806       IREJ = 0
14807       IF1B = 0
14808       IF2B = 0
14809       XMI  = XM
14810
14811 * BAMJET indices of partons
14812       IF1A = IDT_IPDG2B(IF1,1,2)
14813       IF (ABS(IF1).GE.1000) IF1B = IDT_IPDG2B(IF1,2,2)
14814       IF2A = IDT_IPDG2B(IF2,1,2)
14815       IF (ABS(IF2).GE.1000) IF2B = IDT_IPDG2B(IF2,2,2)
14816
14817 * get kind of chains (1 - q-aq, 2 - q-qq/aq-aqaq)
14818       IDCH = 2
14819       IF ((IF1B.EQ.0).AND.(IF2B.EQ.0)) IDCH = 1
14820
14821 * check for resonance mass
14822       CALL DT_CH2RES(IF1A,IF1B,IF2A,IF2B,IDR,IDXR,XMI,XMN,IDCH,IREJ1)
14823       IF (IREJ1.NE.0) GOTO 9999
14824
14825       XM = XMN
14826       RETURN
14827
14828  9999 CONTINUE
14829       IREJ = 1
14830       RETURN
14831       END
14832
14833 *$ CREATE DT_LMKINE.FOR
14834 *COPY DT_LMKINE
14835 *
14836 *===lmkine=============================================================*
14837 *
14838       SUBROUTINE DT_LMKINE(IFP1,IFP2,KP,IFT1,IFT2,KT,IREJ)
14839
14840 ************************************************************************
14841 * Kinematical treatment of low-mass excitations.                       *
14842 * This version dated 12.02.95 is written by S. Roesler                 *
14843 ************************************************************************
14844
14845       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14846       SAVE
14847
14848       PARAMETER ( LINP = 10 ,
14849      &            LOUT = 6 ,
14850      &            LDAT = 9 )
14851
14852       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14853
14854 * flags for input different options
14855       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
14856       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
14857      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
14858
14859 * kinematics of diffractive interactions (DTUNUC 1.x)
14860       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14861      &                PPF(4),PTF(4),
14862      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14863      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14864
14865       DIMENSION P1(4),P2(4)
14866
14867       IREJ = 0
14868
14869       IF (KP.EQ.1) THEN
14870          PABS = SQRT(PPF(1)**2+PPF(2)**2+PPF(3)**2)
14871          POE  = PPF(4)/PABS
14872          FAC1 = OHALF*(POE+ONE)
14873          FAC2 = -OHALF*(POE-ONE)
14874          DO 1 K=1,3
14875             PPLM1(K) = FAC1*PPF(K)
14876             PPLM2(K) = FAC2*PPF(K)
14877     1    CONTINUE
14878          PPLM1(4) = FAC1*PABS
14879          PPLM2(4) = -FAC2*PABS
14880          IF (IMSHL.EQ.1) THEN
14881
14882             XM1 = PYMASS(IFP1)
14883             XM2 = PYMASS(IFP2)
14884
14885             CALL DT_MASHEL(PPLM1,PPLM2,XM1,XM2,P1,P2,IREJ1)
14886             IF (IREJ1.NE.0) GOTO 9999
14887             DO 2 K=1,4
14888                PPLM1(K) = P1(K)
14889                PPLM2(K) = P2(K)
14890     2       CONTINUE
14891          ENDIF
14892       ENDIF
14893
14894       IF (KT.EQ.1) THEN
14895          PABS = SQRT(PTF(1)**2+PTF(2)**2+PTF(3)**2)
14896          POE  = PTF(4)/PABS
14897          FAC1 = OHALF*(POE+ONE)
14898          FAC2 = -OHALF*(POE-ONE)
14899          DO 3 K=1,3
14900             PTLM2(K) = FAC1*PTF(K)
14901             PTLM1(K) = FAC2*PTF(K)
14902     3    CONTINUE
14903          PTLM2(4) = FAC1*PABS
14904          PTLM1(4) = -FAC2*PABS
14905          IF (IMSHL.EQ.1) THEN
14906
14907             XM1 = PYMASS(IFT1)
14908             XM2 = PYMASS(IFT2)
14909
14910             CALL DT_MASHEL(PTLM1,PTLM2,XM1,XM2,P1,P2,IREJ1)
14911             IF (IREJ1.NE.0) GOTO 9999
14912             DO 4 K=1,4
14913                PTLM1(K) = P1(K)
14914                PTLM2(K) = P2(K)
14915     4       CONTINUE
14916          ENDIF
14917       ENDIF
14918
14919       RETURN
14920
14921  9999 CONTINUE
14922       WRITE(LOUT,'(A)') 'LMKINE:   kinematical treatment rejected'
14923       IREJ = 1
14924       RETURN
14925       END
14926
14927 *$ CREATE DT_DIFINI.FOR
14928 *COPY DT_DIFINI
14929 *
14930 *===difini=============================================================*
14931 *
14932       SUBROUTINE DT_DIFINI
14933
14934 ************************************************************************
14935 * Initialization of common /DTDIKI/                                    *
14936 * This version dated 12.02.95 is written by S. Roesler                 *
14937 ************************************************************************
14938
14939       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14940       SAVE
14941
14942       PARAMETER ( LINP = 10 ,
14943      &            LOUT = 6 ,
14944      &            LDAT = 9 )
14945
14946       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
14947
14948 * kinematics of diffractive interactions (DTUNUC 1.x)
14949       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
14950      &                PPF(4),PTF(4),
14951      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
14952      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
14953
14954       DO 1 K=1,4
14955          PPOM(K)  = ZERO
14956          PSC(K)   = ZERO
14957          PPF(K)   = ZERO
14958          PTF(K)   = ZERO
14959          PPLM1(K) = ZERO
14960          PPLM2(K) = ZERO
14961          PTLM1(K) = ZERO
14962          PTLM2(K) = ZERO
14963     1 CONTINUE
14964       DO 2 K=1,2
14965          XPH(K)   = ZERO
14966          XPPO(K)  = ZERO
14967          XTH(K)   = ZERO
14968          XTPO(K)  = ZERO
14969          IFPPO(K) = 0
14970          IFTPO(K) = 0
14971     2 CONTINUE
14972       IDPR  = 0
14973       IDXPR = 0
14974       IDTR  = 0
14975       IDXTR = 0
14976
14977       RETURN
14978       END
14979
14980 *$ CREATE DT_DIFPUT.FOR
14981 *COPY DT_DIFPUT
14982 *
14983 *===difput=============================================================*
14984 *
14985       SUBROUTINE DT_DIFPUT(IFP1,IFP2,PP,MOP,KP,IFT1,IFT2,PT,MOT,KT,NCSY,
14986      &                                                          IREJ)
14987
14988 ************************************************************************
14989 * Dump diffractive chains into DTEVT1                                  *
14990 * This version dated 12.02.95 is written by S. Roesler                 *
14991 ************************************************************************
14992
14993       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
14994       SAVE
14995
14996       PARAMETER ( LINP = 10 ,
14997      &            LOUT = 6 ,
14998      &            LDAT = 9 )
14999
15000       PARAMETER (ZERO=0.0D0,OHALF=0.5D0,ONE=1.0D0)
15001
15002       LOGICAL LCHK
15003
15004 * kinematics of diffractive interactions (DTUNUC 1.x)
15005       COMMON /DTDIKI/ XPH(2),XPPO(2),XTH(2),XTPO(2),PPOM(4),PSC(4),
15006      &                PPF(4),PTF(4),
15007      &                PPLM1(4),PPLM2(4),PTLM1(4),PTLM2(4),
15008      &                IDPR,IDXPR,IDTR,IDXTR,IFPPO(2),IFTPO(2)
15009
15010 * event history
15011
15012       PARAMETER (NMXHKK=200000)
15013
15014       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15015      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15016      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15017
15018 * extended event history
15019       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15020      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15021      &                IHIST(2,NMXHKK)
15022
15023 * rejection counter
15024       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
15025      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
15026      &                IREXCI(3),IRDIFF(2),IRINC
15027
15028       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4),PCH(4),PP(4),PT(4),
15029      &          P1(4),P2(4),P3(4),P4(4)
15030
15031       IREJ = 0
15032
15033       IF (KP.EQ.1) THEN
15034          DO 1 K=1,4
15035             PCH(K) = PPLM1(K)+PPLM2(K)
15036     1    CONTINUE
15037          ID1 = IFP1
15038          ID2 = IFP2
15039          IF (DT_RNDM(PT).GT.OHALF) THEN
15040             ID1 = IFP2
15041             ID2 = IFP1
15042          ENDIF
15043          CALL DT_EVTPUT(21,ID1,MOP,0,PPLM1(1),PPLM1(2),PPLM1(3),
15044      &                                        PPLM1(4),0,0,0)
15045          CALL DT_EVTPUT(21,ID2,MOP,0,PPLM2(1),PPLM2(2),PPLM2(3),
15046      &                                        PPLM2(4),0,0,0)
15047          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15048      &                                              IDPR,IDXPR,8)
15049       ELSEIF (KP.EQ.2) THEN
15050          DO 2 K=1,4
15051             PP1(K) = XPH(1)*PP(K)
15052             PP2(K) = XPH(2)*PP(K)
15053             PT1(K) = -XPPO(1)*PPOM(K)
15054             PT2(K) = -XPPO(2)*PPOM(K)
15055     2    CONTINUE
15056          CALL  DT_CHKCSY(IFP1,IFPPO(1),LCHK)
15057          XM1 = ZERO
15058          XM2 = ZERO
15059          IF (LCHK) THEN
15060             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15061             IF (IREJ1.NE.0) GOTO 9999
15062             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15063             IF (IREJ1.NE.0) GOTO 9999
15064             DO 3 K=1,4
15065                PP1(K) = P1(K)
15066                PT1(K) = P2(K)
15067                PP2(K) = P3(K)
15068                PT2(K) = P4(K)
15069     3       CONTINUE
15070             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15071      &                                                       0,0,8)
15072             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15073      &                                             PT1(4),0,0,8)
15074             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15075      &                                                       0,0,8)
15076             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15077      &                                             PT2(4),0,0,8)
15078          ELSE
15079             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15080             IF (IREJ1.NE.0) GOTO 9999
15081             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15082             IF (IREJ1.NE.0) GOTO 9999
15083             DO 4 K=1,4
15084                PP1(K) = P1(K)
15085                PT2(K) = P2(K)
15086                PP2(K) = P3(K)
15087                PT1(K) = P4(K)
15088     4       CONTINUE
15089             CALL DT_EVTPUT(-21,IFP1,MOP,0,PP1(1),PP1(2),PP1(3),PP1(4),
15090      &                                                       0,0,8)
15091             CALL DT_EVTPUT(-41,IFPPO(2),MOT,0,PT2(1),PT2(2),PT2(3),
15092      &                                                PT2(4),0,0,8)
15093             CALL DT_EVTPUT(-21,IFP2,MOP,0,PP2(1),PP2(2),PP2(3),PP2(4),
15094      &                                                       0,0,8)
15095             CALL DT_EVTPUT(-41,IFPPO(1),MOT,0,PT1(1),PT1(2),PT1(3),
15096      &                                                PT1(4),0,0,8)
15097          ENDIF
15098          NCSY = NCSY+1
15099       ELSE
15100          CALL DT_EVTPUT(1,IDHKK(MOP),MOP,0,PSC(1),PSC(2),PSC(3),PSC(4),
15101      &                                                        0,0,0)
15102       ENDIF
15103
15104       IF (KT.EQ.1) THEN
15105          DO 5 K=1,4
15106             PCH(K) = PTLM1(K)+PTLM2(K)
15107     5    CONTINUE
15108          ID1 = IFT1
15109          ID2 = IFT2
15110          IF (DT_RNDM(PT).GT.OHALF) THEN
15111             ID1 = IFT2
15112             ID2 = IFT1
15113          ENDIF
15114          CALL DT_EVTPUT(22,ID1,MOT,0,PTLM1(1),PTLM1(2),PTLM1(3),
15115      &                                              PTLM1(4),0,0,0)
15116          CALL DT_EVTPUT(22,ID2,MOT,0,PTLM2(1),PTLM2(2),PTLM2(3),
15117      &                                              PTLM2(4),0,0,0)
15118          CALL DT_EVTPUT(281,88888,-2,-1,PCH(1),PCH(2),PCH(3),PCH(4),
15119      &                                              IDTR,IDXTR,8)
15120       ELSEIF (KT.EQ.2) THEN
15121          DO 6 K=1,4
15122             PP1(K) = XTPO(1)*PPOM(K)
15123             PP2(K) = XTPO(2)*PPOM(K)
15124             PT1(K) = XTH(2)*PT(K)
15125             PT2(K) = XTH(1)*PT(K)
15126     6    CONTINUE
15127          CALL  DT_CHKCSY(IFTPO(1),IFT1,LCHK)
15128          XM1 = ZERO
15129          XM2 = ZERO
15130          IF (LCHK) THEN
15131             CALL DT_MASHEL(PP1,PT1,XM1,XM2,P1,P2,IREJ1)
15132             IF (IREJ1.NE.0) GOTO 9999
15133             CALL DT_MASHEL(PP2,PT2,XM1,XM2,P3,P4,IREJ1)
15134             IF (IREJ1.NE.0) GOTO 9999
15135             DO 7 K=1,4
15136                PP1(K) = P1(K)
15137                PT1(K) = P2(K)
15138                PP2(K) = P3(K)
15139                PT2(K) = P4(K)
15140     7       CONTINUE
15141             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15142      &                                                PP1(4),0,0,8)
15143             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15144      &                                                       0,0,8)
15145             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15146      &                                                PP2(4),0,0,8)
15147             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15148      &                                                       0,0,8)
15149          ELSE
15150             CALL DT_MASHEL(PP1,PT2,XM1,XM2,P1,P2,IREJ1)
15151             IF (IREJ1.NE.0) GOTO 9999
15152             CALL DT_MASHEL(PP2,PT1,XM1,XM2,P3,P4,IREJ1)
15153             IF (IREJ1.NE.0) GOTO 9999
15154             DO 8 K=1,4
15155                PP1(K) = P1(K)
15156                PT2(K) = P2(K)
15157                PP2(K) = P3(K)
15158                PT1(K) = P4(K)
15159     8       CONTINUE
15160             CALL DT_EVTPUT(-41,IFTPO(1),MOP,0,PP1(1),PP1(2),PP1(3),
15161      &                                                PP1(4),0,0,8)
15162             CALL DT_EVTPUT(-21,IFT2,MOT,0,PT2(1),PT2(2),PT2(3),PT2(4),
15163      &                                                       0,0,8)
15164             CALL DT_EVTPUT(-41,IFTPO(2),MOP,0,PP2(1),PP2(2),PP2(3),
15165      &                                                PP2(4),0,0,8)
15166             CALL DT_EVTPUT(-21,IFT1,MOT,0,PT1(1),PT1(2),PT1(3),PT1(4),
15167      &                                                       0,0,8)
15168          ENDIF
15169          NCSY = NCSY+1
15170       ELSE
15171          CALL DT_EVTPUT(1,IDHKK(MOT),MOT,0,PSC(1),PSC(2),PSC(3),PSC(4),
15172      &                                                        0,0,0)
15173       ENDIF
15174
15175       RETURN
15176
15177  9999 CONTINUE
15178       IRDIFF(2) = IRDIFF(2)+1
15179       IREJ      = 1
15180       RETURN
15181       END
15182 *$ CREATE DT_EVTFRG.FOR
15183 *COPY DT_EVTFRG
15184 *
15185 *===evtfrg=============================================================*
15186 *
15187       SUBROUTINE DT_EVTFRG(KMODE,NFRG,NPYMEM,IREJ)
15188
15189 ************************************************************************
15190 * Hadronization of chains in DTEVT1.                                   *
15191 *                                                                      *
15192 * Input:                                                               *
15193 *   KMODE = 1   hadronization of PHOJET-chains (id=77xxx)              *
15194 *         = 2   hadronization of DTUNUC-chains (id=88xxx)              *
15195 *   NFRG  if KMODE = 1 : upper index of PHOJET-scatterings to be       *
15196 *                        hadronized with one PYEXEC call               *
15197 *         if KMODE = 2 : max. number of DTUNUC-chains to be hadronized *
15198 *                        with one PYEXEC call                          *
15199 * Output:                                                              *
15200 *   NPYMEM      number of entries in JETSET-common after hadronization *
15201 *   IREJ        rejection flag                                         *
15202 *                                                                      *
15203 * This version dated 17.09.00 is written by S. Roesler                 *
15204 ************************************************************************
15205
15206       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15207       SAVE
15208
15209       PARAMETER ( LINP = 10 ,
15210      &            LOUT = 6 ,
15211      &            LDAT = 9 )
15212
15213       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1)
15214       PARAMETER (ONE=1.0D0,ZERO=0.0D0)
15215
15216       LOGICAL LACCEP
15217
15218       PARAMETER (MXJOIN=200)
15219
15220 * event history
15221
15222       PARAMETER (NMXHKK=200000)
15223
15224       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15225      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15226      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15227
15228 * extended event history
15229       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15230      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15231      &                IHIST(2,NMXHKK)
15232
15233 * flags for input different options
15234       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15235       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15236      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15237
15238 * statistics
15239       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
15240      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
15241      &                ICEVTG(8,0:30)
15242
15243 * flags for diffractive interactions (DTUNUC 1.x)
15244       COMMON /DTFLG3/ ISINGD,IDOUBD,IFLAGD,IDIFF
15245
15246 * nucleon-nucleon event-generator
15247       CHARACTER*8 CMODEL
15248       LOGICAL LPHOIN
15249       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
15250 * phojet
15251
15252 C  model switches and parameters
15253       CHARACTER*8 MDLNA
15254       INTEGER ISWMDL,IPAMDL
15255       DOUBLE PRECISION PARMDL
15256       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
15257 * jetset
15258
15259       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15260       PARAMETER (MAXLND=4000)
15261       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15262
15263       INTEGER PYK
15264
15265       DIMENSION IJOIN(MXJOIN),ISJOIN(MXJOIN),IHISMO(8000),IFLG(4000)
15266
15267       MODE = KMODE
15268       ISTSTG = 7
15269       IF (MODE.NE.1) ISTSTG = 8
15270       IREJ = 0
15271
15272       IP     = 0
15273       ISH    = 0
15274       INIEMC = 1
15275       NEND   = NHKK
15276       NACCEP = 0
15277       IFRG   = 0
15278       IF (NPOINT(4).LE.NPOINT(3)) NPOINT(4) = NHKK+1
15279       DO 10 I=NPOINT(3),NEND
15280 * sr 14.02.00: seems to be not necessary anymore, commented
15281 C        LACCEP = ((NOBAM(I).EQ.0).AND.(MODE.EQ.1)).OR.
15282 C    &            ((NOBAM(I).NE.0).AND.(MODE.EQ.2))
15283          LACCEP = .TRUE.
15284 * pick up chains from dtevt1
15285          IDCHK = IDHKK(I)/10000
15286          IF ((IDCHK.EQ.ISTSTG).AND.LACCEP) THEN
15287             IF (IDCHK.EQ.7) THEN
15288                IPJE = IDHKK(I)-IDCHK*10000
15289                IF (IPJE.NE.IFRG) THEN
15290                   IFRG = IPJE
15291                   IF (IFRG.GT.NFRG) GOTO 16
15292                ENDIF
15293             ELSE
15294                IPJE = 1
15295                IFRG = IFRG+1
15296                IF (IFRG.GT.NFRG) THEN
15297                   NFRG = -1
15298                   GOTO 16
15299                ENDIF
15300             ENDIF
15301 *   statistics counter
15302 c           IF (IDCH(I).LE.8)
15303 c    &         ICCHAI(2,IDCH(I)) = ICCHAI(2,IDCH(I))+1
15304 c           IF (IDRES(I).NE.0) ICRES(IDCH(I)) = ICRES(IDCH(I))+1
15305 * special treatment for small chains already corrected to hadrons
15306             IF (IDRES(I).NE.0) THEN
15307                IF (IDRES(I).EQ.11) THEN
15308                   ID = IDXRES(I)
15309                ELSE
15310                   ID = IDT_IPDGHA(IDXRES(I))
15311                ENDIF
15312                IF (LEMCCK) THEN
15313                   CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15314      &                              PHKK(4,I),INIEMC,IDUM,IDUM)
15315                   INIEMC = 2
15316                ENDIF
15317                IP = IP+1
15318                IF (IP.GT.MSTU(4)) STOP ' NEWFRA 1: IP.GT.MSTU(4) !'
15319                P(IP,1) = PHKK(1,I)
15320                P(IP,2) = PHKK(2,I)
15321                P(IP,3) = PHKK(3,I)
15322                P(IP,4) = PHKK(4,I)
15323                P(IP,5) = PHKK(5,I)
15324                K(IP,1) = 1
15325                K(IP,2) = ID
15326                K(IP,3) = 0
15327                K(IP,4) = 0
15328                K(IP,5) = 0
15329                IHIST(2,I) = 10000*IPJE+IP
15330                IF (IHIST(1,I).LE.-100) THEN
15331                   ISH = ISH+1
15332                   IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15333                   ISJOIN(ISH) = I
15334                ENDIF
15335                N = IP
15336                IHISMO(IP) = I
15337             ELSE
15338                IJ  = 0
15339                DO 11 KK=JMOHKK(1,I),JMOHKK(2,I)
15340                   IF (LEMCCK) THEN
15341                      CALL DT_EVTEMC(PHKK(1,KK),PHKK(2,KK),PHKK(3,KK),
15342      &                                   PHKK(4,KK),INIEMC,IDUM,IDUM)
15343                      CALL DT_EVTFLC(IDHKK(KK),1,INIEMC,IDUM,IDUM)
15344                      INIEMC = 2
15345                   ENDIF
15346                   ID = IDHKK(KK)
15347                   IF (ID.EQ.0) ID = 21
15348 c                  PTOT = SQRT(PHKK(1,KK)**2+PHKK(2,KK)**2+PHKK(3,KK)**2)
15349 c                  AM0  = SQRT(ABS((PHKK(4,KK)-PTOT)*(PHKK(4,KK)+PTOT)))
15350
15351 c                  AMRQ   = PYMASS(ID)
15352
15353 c                  AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
15354 c                  IF ((ABS(AMDIF2).GT.TINY3).AND.(PTOT.GT.ZERO).AND.
15355 c     &                (ABS(IDIFF).EQ.0)) THEN
15356 cC                    WRITE(LOUT,*)'here: ',NEVHKK,AM0,AMRQ
15357 c                     DELTA      = -AMDIF2/(2.0D0*(PHKK(4,KK)+PTOT))
15358 c                     PHKK(4,KK) = PHKK(4,KK)+DELTA
15359 c                     PTOT1      = PTOT-DELTA
15360 c                     PHKK(1,KK) = PHKK(1,KK)*PTOT1/PTOT
15361 c                     PHKK(2,KK) = PHKK(2,KK)*PTOT1/PTOT
15362 c                     PHKK(3,KK) = PHKK(3,KK)*PTOT1/PTOT
15363 c                     PHKK(5,KK) = AMRQ
15364 c                  ENDIF
15365                   IP = IP+1
15366                   IF (IP.GT.MSTU(4)) STOP ' NEWFRA 2: IP.GT.MSTU(4) !'
15367                   P(IP,1) = PHKK(1,KK)
15368                   P(IP,2) = PHKK(2,KK)
15369                   P(IP,3) = PHKK(3,KK)
15370                   P(IP,4) = PHKK(4,KK)
15371                   P(IP,5) = PHKK(5,KK)
15372                   K(IP,1) = 1
15373                   K(IP,2) = ID
15374                   K(IP,3) = 0
15375                   K(IP,4) = 0
15376                   K(IP,5) = 0
15377                   IHIST(2,KK) = 10000*IPJE+IP
15378                   IF (IHIST(1,KK).LE.-100) THEN
15379                      ISH = ISH+1
15380                      IF (ISH.GT.MXJOIN) STOP 'ISH > MXJOIN !'
15381                      ISJOIN(ISH) = KK
15382                   ENDIF
15383                   IJ = IJ+1
15384                   IF (IJ.GT.MXJOIN) STOP 'IJ > MXJOIN !'
15385                   IJOIN(IJ)  = IP
15386                   IHISMO(IP) = I
15387    11          CONTINUE
15388                N = IP
15389 * join the two-parton system
15390
15391                CALL PYJOIN(IJ,IJOIN)
15392
15393             ENDIF
15394             IDHKK(I) = 99999
15395          ENDIF
15396    10 CONTINUE
15397    16 CONTINUE
15398       N = IP
15399
15400       IF (IP.GT.0) THEN
15401
15402 * final state parton shower
15403          DO 136 NPJE=1,IPJE
15404             IF ((MCGENE.EQ.2).AND.(ISH.GE.2)) THEN
15405                IF ((ISWMDL(8).EQ.1).OR.(ISWMDL(8).EQ.3)) THEN
15406                   DO 130 K1=1,ISH
15407                      IF (ISJOIN(K1).EQ.0) GOTO 130
15408                      I = ISJOIN(K1)
15409                      IF ((IPAMDL(102).EQ.1).AND.(IHIST(1,I).NE.-100))
15410      &                                                       GOTO 130
15411                      IH1 = IHIST(2,I)/10000
15412                      IF (IH1.NE.NPJE) GOTO 130
15413                      IH1 = IHIST(2,I)-IH1*10000
15414                      DO 135 K2=K1+1,ISH
15415                         IF (ISJOIN(K2).EQ.0) GOTO 135
15416                         II = ISJOIN(K2)
15417                         IH2 = IHIST(2,II)/10000
15418                         IF (IH2.NE.NPJE) GOTO 135
15419                         IH2 = IHIST(2,II)-IH2*10000
15420                         IF (IHIST(1,I).EQ.IHIST(1,II)) THEN
15421                            PT1 = SQRT(PHKK(1,II)**2+PHKK(2,II)**2)
15422                            PT2 = SQRT(PHKK(1, I)**2+PHKK(2, I)**2)
15423
15424                            RQLUN = MIN(PT1,PT2)
15425                            CALL PYSHOW(IH1,IH2,RQLUN)
15426
15427                            ISJOIN(K1) = 0
15428                            ISJOIN(K2) = 0
15429                            GOTO 130
15430                         ENDIF
15431  135                 CONTINUE
15432  130              CONTINUE
15433                ENDIF
15434             ENDIF
15435  136     CONTINUE
15436
15437          CALL DT_INITJS(MODE)
15438 * hadronization
15439
15440          CALL PYEXEC
15441
15442          IF (MSTU(24).NE.0) THEN
15443             WRITE(LOUT,*) ' JETSET-reject at event',
15444      &                    NEVHKK,MSTU(24),KMODE
15445 C           CALL DT_EVTOUT(4)
15446
15447 C           CALL PYLIST(2)
15448
15449             GOTO 9999
15450          ENDIF
15451
15452 *   number of entries in LUJETS
15453
15454          NLINES = PYK(0,1)
15455
15456          NPYMEM = NLINES
15457
15458          DO 12 I=1,NLINES
15459             IFLG(I) = 0
15460    12    CONTINUE
15461
15462          DO 13 II=1,NLINES
15463
15464             IF ((PYK(II,7).EQ.1).AND.(IFLG(II).NE.1)) THEN
15465
15466 *  pick up mother resonance if possible and put it together with
15467 *  their decay-products into the common
15468                IDXMOR = K(II,3)
15469                IF ((IDXMOR.GE.1).AND.(IDXMOR.LE.MAXLND)) THEN
15470                   KFMOR = K(IDXMOR,2)
15471                   ISMOR = K(IDXMOR,1)
15472                ELSE
15473                   KFMOR = 91
15474                   ISMOR = 1
15475                ENDIF
15476                IF ((KFMOR.NE.91).AND.(KFMOR.NE.92).AND.
15477      &             (KFMOR.NE.94).AND.(ISMOR.EQ.11)) THEN
15478                   ID = K(IDXMOR,2)
15479                   MO = IHISMO(PYK(IDXMOR,15))
15480                   PX = PYP(IDXMOR,1)
15481                   PY = PYP(IDXMOR,2)
15482                   PZ = PYP(IDXMOR,3)
15483                   PE = PYP(IDXMOR,4)
15484
15485                   CALL DT_EVTPUT(2,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15486                   IFLG(IDXMOR) = 1
15487                   MO = NHKK
15488                   DO 15 JDAUG=K(IDXMOR,4),K(IDXMOR,5)
15489                      IF (PYK(JDAUG,7).EQ.1) THEN
15490                         ID = PYK(JDAUG,8)
15491                         PX = PYP(JDAUG,1)
15492                         PY = PYP(JDAUG,2)
15493                         PZ = PYP(JDAUG,3)
15494                         PE = PYP(JDAUG,4)
15495
15496                         CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15497                         IF (LEMCCK) THEN
15498                            PX = -PYP(JDAUG,1)
15499                            PY = -PYP(JDAUG,2)
15500                            PZ = -PYP(JDAUG,3)
15501                            PE = -PYP(JDAUG,4)
15502
15503                            CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15504                         ENDIF
15505                         IFLG(JDAUG) = 1
15506                      ENDIF
15507    15             CONTINUE
15508                ELSE
15509 *  there was no mother resonance
15510                   MO = IHISMO(PYK(II,15))
15511                   ID = PYK(II,8)
15512                   PX = PYP(II,1)
15513                   PY = PYP(II,2)
15514                   PZ = PYP(II,3)
15515                   PE = PYP(II,4)
15516
15517                   CALL DT_EVTPUT(1,ID,MO,0,PX,PY,PZ,PE,0,0,0)
15518                   IF (LEMCCK) THEN
15519                      PX = -PYP(II,1)
15520                      PY = -PYP(II,2)
15521                      PZ = -PYP(II,3)
15522                      PE = -PYP(II,4)
15523
15524                      CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM,IDUM)
15525                   ENDIF
15526                ENDIF
15527             ENDIF
15528    13    CONTINUE
15529          IF (LEMCCK) THEN
15530             CHKLEV = TINY1
15531             CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,6,IREJ1)
15532 C           IF (IREJ1.NE.0) CALL DT_EVTOUT(4)
15533          ENDIF
15534
15535 * global energy-momentum & flavor conservation check
15536 **sr 16.5. this check is skipped in case of phojet-treatment
15537          IF (MCGENE.EQ.1)
15538      &      CALL DT_EMC2(9,10,0,0,0,3,1,0,0,0,0,3,4,12,IREJ3)
15539
15540 * update statistics-counter for diffraction
15541 c        IF (IFLAGD.NE.0) THEN
15542 c           ICDIFF(1) = ICDIFF(1)+1
15543 c           IF (IFLAGD.EQ. 1) ICDIFF(2) = ICDIFF(2)+1
15544 c           IF (IFLAGD.EQ. 2) ICDIFF(3) = ICDIFF(3)+1
15545 c           IF (IFLAGD.EQ.-1) ICDIFF(4) = ICDIFF(4)+1
15546 c           IF (IFLAGD.EQ.-2) ICDIFF(5) = ICDIFF(5)+1
15547 c        ENDIF
15548
15549       ENDIF
15550
15551       RETURN
15552
15553  9999 CONTINUE
15554       IREJ = 1
15555       RETURN
15556       END
15557
15558 *$ CREATE DT_DECAYS.FOR
15559 *COPY DT_DECAYS
15560 *
15561 *===decay==============================================================*
15562 *
15563       SUBROUTINE DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15564
15565 ************************************************************************
15566 * Resonance-decay.                                                     *
15567 * This subroutine replaces DDECAY/DECHKK.                              *
15568 *             PIN(4)      4-momentum of resonance          (input)     *
15569 *             IDXIN       BAMJET-index of resonance        (input)     *
15570 *             POUT(20,4)  4-momenta of decay-products      (output)    *
15571 *             IDXOUT(20)  BAMJET-indices of decay-products (output)    *
15572 *             NSEC        number of secondaries            (output)    *
15573 * Adopted from the original version DECHKK.                            *
15574 * This version dated 09.01.95 is written by S. Roesler                 *
15575 ************************************************************************
15576
15577       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15578       SAVE
15579
15580       PARAMETER ( LINP = 10 ,
15581      &            LOUT = 6 ,
15582      &            LDAT = 9 )
15583
15584       PARAMETER (TINY17=1.0D-17)
15585
15586 * HADRIN: decay channel information
15587       PARAMETER (IDMAX9=602)
15588       CHARACTER*8 ZKNAME
15589       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
15590
15591 * particle properties (BAMJET index convention)
15592       CHARACTER*8  ANAME
15593       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
15594      &                IICH(210),IIBAR(210),K1(210),K2(210)
15595
15596 * flags for input different options
15597       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15598       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15599      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15600
15601       DIMENSION PIN(4),PI(20,4),POUT(20,4),IDXOUT(20),
15602      &          EF(3),PF(3),PFF(3),IDXSTK(20),IDX(3),
15603      &          CODF(3),COFF(3),SIFF(3),DCOS(3),DCOSF(3)
15604
15605 * ISTAB = 1 strong and weak decays
15606 *       = 2 strong decays only
15607 *       = 3 strong decays, weak decays for charmed particles and tau
15608 *           leptons only
15609       DATA ISTAB /2/
15610
15611       IREJ = 0
15612       NSEC = 0
15613 * put initial resonance to stack
15614       NSTK = 1
15615       IDXSTK(NSTK) = IDXIN
15616       DO 5 I=1,4
15617          PI(NSTK,I) = PIN(I)
15618     5 CONTINUE
15619
15620 * store initial configuration for energy-momentum cons. check
15621       IF (LEMCCK) CALL DT_EVTEMC(PI(NSTK,1),PI(NSTK,2),PI(NSTK,3),
15622      &                                   PI(NSTK,4),1,IDUM,IDUM)
15623
15624   100 CONTINUE
15625 * get particle from stack
15626       IDXI = IDXSTK(NSTK)
15627 * skip stable particles
15628       IF (ISTAB.EQ.1) THEN
15629          IF ((IDXI.EQ.135).OR. (IDXI.EQ.136)) GOTO 10
15630          IF ((IDXI.GE.  1).AND.(IDXI.LE.  7)) GOTO 10
15631       ELSEIF (ISTAB.EQ.2) THEN
15632          IF ((IDXI.GE.  1).AND.(IDXI.LE. 30)) GOTO 10
15633          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15634          IF ((IDXI.GE.115).AND.(IDXI.LE.122)) GOTO 10
15635          IF ((IDXI.GE.131).AND.(IDXI.LE.136)) GOTO 10
15636          IF ( IDXI.EQ.109)                    GOTO 10
15637          IF ((IDXI.GE.137).AND.(IDXI.LE.160)) GOTO 10
15638       ELSEIF (ISTAB.EQ.3) THEN
15639          IF ((IDXI.GE.  1).AND.(IDXI.LE. 23)) GOTO 10
15640          IF ((IDXI.GE. 97).AND.(IDXI.LE.103)) GOTO 10
15641          IF ((IDXI.GE.109).AND.(IDXI.LE.115)) GOTO 10
15642          IF ((IDXI.GE.133).AND.(IDXI.LE.136)) GOTO 10
15643       ENDIF
15644
15645 * calculate direction cosines and Lorentz-parameter of decaying part.
15646       PTOT = SQRT(PI(NSTK,1)**2+PI(NSTK,2)**2+PI(NSTK,3)**2)
15647       PTOT = MAX(PTOT,TINY17)
15648       DO 1 I=1,3
15649          DCOS(I) = PI(NSTK,I)/PTOT
15650     1 CONTINUE
15651       GAM  = PI(NSTK,4)/AAM(IDXI)
15652       BGAM = PTOT/AAM(IDXI)
15653
15654 * get decay-channel
15655       KCHAN = K1(IDXI)-1
15656     2 CONTINUE
15657       KCHAN = KCHAN+1
15658       IF ((DT_RNDM(GAM)-TINY17).GT.WT(KCHAN)) GOTO 2
15659
15660 * identities of secondaries
15661       IDX(1) = NZK(KCHAN,1)
15662       IDX(2) = NZK(KCHAN,2)
15663       IF (IDX(2).LT.1) GOTO 9999
15664       IDX(3) = NZK(KCHAN,3)
15665
15666 * handle decay in rest system of decaying particle
15667       IF (IDX(3).EQ.0) THEN
15668 *   two-particle decay
15669          NDEC = 2
15670          CALL DT_DTWOPD(AAM(IDXI),EF(1),EF(2),PF(1),PF(2),
15671      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15672      &               AAM(IDX(1)),AAM(IDX(2)))
15673       ELSE
15674 *   three-particle decay
15675          NDEC = 3
15676          CALL DT_DTHREP(AAM(IDXI),EF(1),EF(2),EF(3),PF(1),PF(2),PF(3),
15677      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
15678      &               CODF(3),COFF(3),SIFF(3),
15679      &               AAM(IDX(1)),AAM(IDX(2)),AAM(IDX(3)))
15680       ENDIF
15681       NSTK = NSTK-1
15682
15683 * transform decay products back
15684       DO 3 I=1,NDEC
15685          NSTK = NSTK+1
15686          CALL DT_DTRAFO(GAM,BGAM,DCOS(1),DCOS(2),DCOS(3),
15687      &               CODF(I),COFF(I),SIFF(I),PF(I),EF(I),
15688      &               PFF(I),DCOSF(1),DCOSF(2),DCOSF(3),PI(NSTK,4))
15689 * add particle to stack
15690          IDXSTK(NSTK) = IDX(I)
15691          DO 4 J=1,3
15692             PI(NSTK,J) = DCOSF(J)*PFF(I)
15693     4    CONTINUE
15694     3 CONTINUE
15695       GOTO 100
15696
15697    10 CONTINUE
15698 * stable particle, put to output-arrays
15699       NSEC = NSEC+1
15700       DO 6 I=1,4
15701          POUT(NSEC,I) = PI(NSTK,I)
15702     6 CONTINUE
15703       IDXOUT(NSEC) = IDXSTK(NSTK)
15704 * store secondaries for energy-momentum conservation check
15705       IF (LEMCCK)
15706      &CALL DT_EVTEMC(-POUT(NSEC,1),-POUT(NSEC,2),-POUT(NSEC,3),
15707      &            -POUT(NSEC,4),2,IDUM,IDUM)
15708       NSTK = NSTK-1
15709       IF (NSTK.GT.0) GOTO 100
15710
15711 * check energy-momentum conservation
15712       IF (LEMCCK) THEN
15713          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,5,IREJ1)
15714          IF (IREJ1.NE.0) GOTO 9999
15715       ENDIF
15716
15717       RETURN
15718
15719  9999 CONTINUE
15720       IREJ = 1
15721       RETURN
15722       END
15723
15724 *$ CREATE DT_DECAY1.FOR
15725 *COPY DT_DECAY1
15726 *
15727 *===decay1=============================================================*
15728 *
15729       SUBROUTINE DT_DECAY1
15730
15731 ************************************************************************
15732 * Decay of resonances stored in DTEVT1.                                *
15733 * This version dated 20.01.95 is written by S. Roesler                 *
15734 ************************************************************************
15735
15736       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15737       SAVE
15738
15739       PARAMETER ( LINP = 10 ,
15740      &            LOUT = 6 ,
15741      &            LDAT = 9 )
15742
15743 * event history
15744
15745       PARAMETER (NMXHKK=200000)
15746
15747       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15748      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15749      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15750
15751 * extended event history
15752       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15753      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15754      &                IHIST(2,NMXHKK)
15755
15756       DIMENSION PIN(4),POUT(20,4),IDXOUT(20)
15757
15758       NEND = NHKK
15759 C     DO 1 I=NPOINT(5),NEND
15760       DO 1 I=NPOINT(4),NEND
15761          IF (ABS(ISTHKK(I)).EQ.1) THEN
15762             DO 2 K=1,4
15763                PIN(K) = PHKK(K,I)
15764     2       CONTINUE
15765             IDXIN = IDBAM(I)
15766             CALL DT_DECAYS(PIN,IDXIN,POUT,IDXOUT,NSEC,IREJ)
15767             IF (NSEC.GT.1) THEN
15768                DO 3 N=1,NSEC
15769                   IDHAD = IDT_IPDGHA(IDXOUT(N))
15770                   CALL DT_EVTPUT(1,IDHAD,I,0,POUT(N,1),POUT(N,2),
15771      &                               POUT(N,3),POUT(N,4),0,0,0)
15772     3          CONTINUE
15773             ENDIF
15774          ENDIF
15775     1 CONTINUE
15776
15777       RETURN
15778       END
15779
15780 *$ CREATE DT_DECPI0.FOR
15781 *COPY DT_DECPI0
15782 *
15783 *===decpi0=============================================================*
15784 *
15785       SUBROUTINE DT_DECPI0
15786
15787 ************************************************************************
15788 * Decay of pi0 handled with JETSET.                                    *
15789 * This version dated 18.02.96 is written by S. Roesler                 *
15790 ************************************************************************
15791
15792       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15793       SAVE
15794
15795       PARAMETER ( LINP = 10 ,
15796      &            LOUT = 6 ,
15797      &            LDAT = 9 )
15798
15799       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0,ZERO=0.0D0)
15800
15801 * event history
15802
15803       PARAMETER (NMXHKK=200000)
15804
15805       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
15806      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
15807      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
15808
15809 * extended event history
15810       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
15811      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
15812      &                IHIST(2,NMXHKK)
15813
15814       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15815       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15816       PARAMETER (MAXLND=4000)
15817       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
15818
15819 * flags for input different options
15820       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15821       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15822      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15823
15824       INTEGER PYCOMP,PYK
15825
15826       DIMENSION IHISMO(NMXHKK),P1(4)
15827
15828       TWOPI = 2.0D0*ATAN2(0.0D0,-1.0D0)
15829
15830       CALL DT_INITJS(2)
15831 * allow pi0 decay
15832
15833       KC = PYCOMP(111)
15834
15835       MDCY(KC,1) = 1
15836
15837       NN  = 0
15838       INI = 0
15839       DO 1 I=1,NHKK
15840          IF ((ISTHKK(I).EQ.1).AND.(IDHKK(I).EQ.111)) THEN
15841             IF (INI.EQ.0) THEN
15842                INI = 1
15843             ELSE
15844                INI = 2
15845             ENDIF
15846             IF (LEMCCK) CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),
15847      &                                    PHKK(4,I),INI,IDUM,IDUM)
15848             PT    = SQRT(PHKK(1,I)**2+PHKK(2,I)**2)
15849             PTOT  = SQRT(PT**2+PHKK(3,I)**2)
15850             COSTH = PHKK(3,I)/(PTOT+TINY10)
15851             IF (COSTH.GT.ONE) THEN
15852                THETA = ZERO
15853             ELSEIF (COSTH.LT.-ONE) THEN
15854                THETA = TWOPI/2.0D0
15855             ELSE
15856                THETA = ACOS(COSTH)
15857             ENDIF
15858             PHI     = ASIN(PHKK(2,I)/(PT  +TINY10))
15859             IF (PHKK(1,I).LT.0.0D0)
15860
15861      &         PHI  = SIGN(TWOPI/2.0D0-ABS(PHI),PHI)
15862
15863             ENER    = PHKK(4,I)
15864             NN      = NN+1
15865             KTEMP   = MSTU(10)
15866             MSTU(10)= 1
15867             P(NN,5) = PHKK(5,I)
15868
15869             CALL PY1ENT(NN,111,ENER,THETA,PHI)
15870
15871             MSTU(10)  = KTEMP
15872             IHISMO(NN)= I
15873          ENDIF
15874     1 CONTINUE
15875       IF (NN.GT.0) THEN
15876
15877          CALL PYEXEC
15878
15879          NLINES = PYK(0,1)
15880
15881          DO 2 II=1,NLINES
15882
15883             IF (PYK(II,7).EQ.1) THEN
15884
15885                DO 3 KK=1,4
15886
15887                   P1(KK) = PYP(II,KK)
15888
15889     3          CONTINUE
15890
15891                ID = PYK(II,8)
15892                MO = IHISMO(PYK(II,15))
15893
15894                CALL DT_EVTPUT(1,ID,MO,0,P1(1),P1(2),P1(3),P1(4),0,0,0)
15895                IF (LEMCCK)
15896      &            CALL DT_EVTEMC(-P1(1),-P1(2),-P1(3),-P1(4),2,
15897      &                                            IDUM,IDUM)
15898 *sr: flag with neg. sign (for HELIOS p/A-W jobs)
15899                ISTHKK(MO) = -2
15900             ENDIF
15901     2    CONTINUE
15902          IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,7000,IREJ1)
15903       ENDIF
15904       MDCY(KC,1) = 0
15905
15906       RETURN
15907       END
15908
15909 *$ CREATE DT_DTWOPD.FOR
15910 *COPY DT_DTWOPD
15911 *
15912 *===dtwopd=============================================================*
15913 *
15914       SUBROUTINE DT_DTWOPD(UMO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,COD2,
15915      &                                            COF2,SIF2,AM1,AM2)
15916
15917 ************************************************************************
15918 * Two-particle decay.                                                  *
15919 *  UMO                 cm-energy of the decaying system       (input)  *
15920 *  AM1/AM2             masses of the decay products           (input)  *
15921 *  ECM1,ECM2/PCM1,PCM2 cm-energies/momenta of the decay prod. (output) *
15922 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15923 * Revised by S. Roesler, 20.11.95                                      *
15924 ************************************************************************
15925
15926       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15927       SAVE
15928
15929       PARAMETER ( LINP = 10 ,
15930      &            LOUT = 6 ,
15931      &            LDAT = 9 )
15932
15933       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,ZERO=0.0D0)
15934
15935       IF (UMO.LT.(AM1+AM2)) THEN
15936          WRITE(LOUT,1000) UMO,AM1,AM2
15937  1000    FORMAT(1X,'DTWOPD:    inconsistent kinematics - UMO,AM1,AM2 ',
15938      &          3E12.3)
15939          STOP
15940       ENDIF
15941
15942       ECM1 = ((UMO-AM2)*(UMO+AM2)+AM1*AM1)/(TWO*UMO)
15943       ECM2 = UMO-ECM1
15944       PCM1 = SQRT((ECM1-AM1)*(ECM1+AM1))
15945       PCM2 = PCM1
15946       CALL DT_DSFECF(SIF1,COF1)
15947       COD1 = TWO*DT_RNDM(PCM2)-ONE
15948       COD2 = -COD1
15949       COF2 = -COF1
15950       SIF2 = -SIF1
15951
15952       RETURN
15953       END
15954
15955 *$ CREATE DT_DTHREP.FOR
15956 *COPY DT_DTHREP
15957 *
15958 *===dthrep=============================================================*
15959 *
15960       SUBROUTINE DT_DTHREP(UMO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,
15961      &                  SIF1,COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
15962
15963 ************************************************************************
15964 * Three-particle decay.                                                *
15965 *  UMO                 cm-energy of the decaying system       (input)  *
15966 *  AM1/2/3             masses of the decay products           (input)  *
15967 *  ECM1/2/2,PCM1/2/3   cm-energies/momenta of the decay prod. (output) *
15968 *  COD,COF,SIF         direction cosines of the decay prod.   (output) *
15969 *                                                                      *
15970 * Threpd89: slight revision by A. Ferrari                              *
15971 * Last change on   11-oct-93   by    Alfredo Ferrari, INFN - Milan     *
15972 * Revised by S. Roesler, 20.11.95                                      *
15973 ************************************************************************
15974
15975       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
15976       SAVE
15977
15978       PARAMETER ( LINP = 10 ,
15979      &            LOUT = 6 ,
15980      &            LDAT = 9 )
15981
15982       PARAMETER ( ANGLSQ = 2.5D-31 )
15983       PARAMETER ( AZRZRZ = 1.0D-30 )
15984       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
15985       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
15986       PARAMETER ( ONEONE = 1.D+00 )
15987       PARAMETER ( TWOTWO = 2.D+00 )
15988       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
15989
15990       COMMON /HNGAMR/ REDU,AMO,AMM(15)
15991
15992 * flags for input different options
15993       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
15994       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
15995      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
15996
15997       DIMENSION F(5),XX(5)
15998       DATA EPS /AZRZRZ/
15999
16000       UMOO=UMO+UMO
16001 C***S1, S2, S3 ARE THE INVARIANT MASSES OF THE PARTICLES 1, 2, 3
16002 C***J. VON NEUMANN - RANDOM - SELECTION OF S2
16003 C***CALCULATION OF THE MAXIMUM OF THE S2 - DISTRIBUTION
16004       UUMO=UMO
16005       AAM1=AM1
16006       AAM2=AM2
16007       AAM3=AM3
16008       GU=(AM2+AM3)**2
16009       GO=(UMO-AM1)**2
16010 *     UFAK=1.0000000000001D0
16011 *     IF (GU.GT.GO) UFAK=0.9999999999999D0
16012       IF (GU.GT.GO) THEN
16013          UFAK=ONEMNS
16014       ELSE
16015          UFAK=ONEPLS
16016       END IF
16017       OFAK=2.D0-UFAK
16018       GU=GU*UFAK
16019       GO=GO*OFAK
16020       DS2=(GO-GU)/99.D0
16021       AM11=AM1*AM1
16022       AM22=AM2*AM2
16023       AM33=AM3*AM3
16024       UMO2=UMO*UMO
16025       RHO2=0.D0
16026       S22=GU
16027       DO 124 I=1,100
16028          S21=S22
16029          S22=GU+(I-1.D0)*DS2
16030          RHO1=RHO2
16031          RHO2=DT_YLAMB(S22,UMO2,AM11)*DT_YLAMB(S22,AM22,AM33)/
16032      *                                             (S22+EPS)
16033          IF(RHO2.LT.RHO1) GO TO 125
16034   124 CONTINUE
16035   125 S2SUP=(S22-S21)*.5D0+S21
16036       SUPRHO=DT_YLAMB(S2SUP,UMO2,AM11)*DT_YLAMB(S2SUP,AM22,AM33)/
16037      *                                           (S2SUP+EPS)
16038       SUPRHO=SUPRHO*1.05D0
16039       XO=S21-DS2
16040       IF (GU.LT.GO.AND.XO.LT.GU) XO=GU
16041       IF (GU.GT.GO.AND.XO.GT.GU) XO=GU
16042       XX(1)=XO
16043       XX(3)=S22
16044       X1=(XO+S22)*0.5D0
16045       XX(2)=X1
16046       F(3)=RHO2
16047       F(1)=DT_YLAMB(XO,UMO2,AM11)*DT_YLAMB(XO,AM22,AM33)/(XO+EPS)
16048       F(2)=DT_YLAMB(X1,UMO2,AM11)*DT_YLAMB(X1,AM22,AM33)/(X1+EPS)
16049       DO 126 I=1,16
16050          X4=(XX(1)+XX(2))*0.5D0
16051          X5=(XX(2)+XX(3))*0.5D0
16052          F(4)=DT_YLAMB(X4,UMO2,AM11)*DT_YLAMB(X4,AM22,AM33)/
16053      *                                               (X4+EPS)
16054          F(5)=DT_YLAMB(X5,UMO2,AM11)*DT_YLAMB(X5,AM22,AM33)/
16055      *                                               (X5+EPS)
16056          XX(4)=X4
16057          XX(5)=X5
16058          DO 128 II=1,5
16059             IA=II
16060             DO 128 III=IA,5
16061                IF (F (II).GE.F (III)) GO TO 128
16062                FH=F(II)
16063                F(II)=F(III)
16064                F(III)=FH
16065                FH=XX(II)
16066                XX(II)=XX(III)
16067                XX(III)=FH
16068 128      CONTINUE
16069          SUPRHO=F(1)
16070          S2SUP=XX(1)
16071          DO 129 II=1,3
16072             IA=II
16073             DO 129 III=IA,3
16074                IF (XX(II).GE.XX(III)) GO TO 129
16075                FH=F(II)
16076                F(II)=F(III)
16077                F(III)=FH
16078                FH=XX(II)
16079                XX(II)=XX(III)
16080                XX(III)=FH
16081 129      CONTINUE
16082 126   CONTINUE
16083       AM23=(AM2+AM3)**2
16084       ITH=0
16085       REDU=2.D0
16086     1 CONTINUE
16087       ITH=ITH+1
16088       IF (ITH.GT.200) REDU=-9.D0
16089       IF (ITH.GT.200) GO TO 400
16090       C=DT_RNDM(REDU)
16091 *     S2=AM23+C*((UMO-AM1)**2-AM23)
16092       S2=AM23+C*(UMO-AM1-AM2-AM3)*(UMO-AM1+AM2+AM3)
16093       Y=DT_RNDM(S2)
16094       Y=Y*SUPRHO
16095       RHO=DT_YLAMB(S2,UMO2,AM11)*DT_YLAMB(S2,AM22,AM33)/S2
16096       IF(Y.GT.RHO) GO TO 1
16097 C***RANDOM SELECTION OF S3 AND CALCULATION OF S1
16098       S1=DT_RNDM(S2)
16099       S1=S1*RHO+AM11+AM22-(S2-UMO2+AM11)*(S2+AM22-AM33)/(2.D0*S2)-
16100      &RHO*.5D0
16101       S3=UMO2+AM11+AM22+AM33-S1-S2
16102       ECM1=(UMO2+AM11-S2)/UMOO
16103       ECM2=(UMO2+AM22-S3)/UMOO
16104       ECM3=(UMO2+AM33-S1)/UMOO
16105       PCM1=SQRT((ECM1+AM1)*(ECM1-AM1))
16106       PCM2=SQRT((ECM2+AM2)*(ECM2-AM2))
16107       PCM3=SQRT((ECM3+AM3)*(ECM3-AM3))
16108       CALL DT_DSFECF(SFE,CFE)
16109 C***TH IS THE ANGLE BETWEEN PARTICLES 1 AND 2
16110 C***TH1, TH2 ARE THE ANGLES BETWEEN PARTICLES 1, 2 AND THE DIRECTION OF
16111       PCM12 = PCM1 * PCM2
16112       IF ( PCM12 .LT. ANGLSQ ) GO TO 200
16113       COSTH=(ECM1*ECM2+0.5D+00*(AM11+AM22-S1))/PCM12
16114       GO TO 300
16115  200  CONTINUE
16116          UW=DT_RNDM(S1)
16117          COSTH=(UW-0.5D+00)*2.D+00
16118  300  CONTINUE
16119 *     IF(ABS(COSTH).GT.0.9999999999999999D0)
16120 *    &COSTH=SIGN(0.9999999999999999D0,COSTH)
16121       IF(ABS(COSTH).GT.ONEONE)
16122      &COSTH=SIGN(ONEONE,COSTH)
16123       IF (REDU.LT.1.D+00) RETURN
16124       COSTH2=(PCM3*PCM3+PCM2*PCM2-PCM1*PCM1)/(2.D+00*PCM2*PCM3)
16125 *     IF(ABS(COSTH2).GT.0.9999999999999999D0)
16126 *    &COSTH2=SIGN(0.9999999999999999D0,COSTH2)
16127       IF(ABS(COSTH2).GT.ONEONE)
16128      &COSTH2=SIGN(ONEONE,COSTH2)
16129       SINTH2=SQRT((ONEONE-COSTH2)*(ONEONE+COSTH2))
16130       SINTH =SQRT((ONEONE-COSTH)*(ONEONE+COSTH))
16131       SINTH1=COSTH2*SINTH-COSTH*SINTH2
16132       COSTH1=COSTH*COSTH2+SINTH2*SINTH
16133 C***RANDOM SELECTION OF THE SPHERICAL COORDINATES OF THE DIRECTION OF PA
16134 C***CFE, SFE ARE COS AND SIN OF THE ROTATION ANGLE OF THE SYSTEM 1, 2 AR
16135 C***THE DIRECTION OF PARTICLE 3
16136 C***CALCULATION OF THE SPHERICAL COORDINATES OF PARTICLES 1, 2
16137       CX11=-COSTH1
16138       CY11=SINTH1*CFE
16139       CZ11=SINTH1*SFE
16140       CX22=-COSTH2
16141       CY22=-SINTH2*CFE
16142       CZ22=-SINTH2*SFE
16143       CALL DT_DSFECF(SIF3,COF3)
16144       COD3=TWOTWO*DT_RNDM(CX11)-ONEONE
16145       SID3=SQRT((1.D+00-COD3)*(1.D+00+COD3))
16146     2 FORMAT(5F20.15)
16147       COD1=CX11*COD3+CZ11*SID3
16148       CHLP=(ONEONE-COD1)*(ONEONE+COD1)
16149       IF(CHLP.LT.1.D-14)WRITE(LOUT,2)COD1,COF3,SID3,
16150      &CX11,CZ11
16151       SID1=SQRT(CHLP)
16152       COF1=(CX11*SID3*COF3-CY11*SIF3-CZ11*COD3*COF3)/SID1
16153       SIF1=(CX11*SID3*SIF3+CY11*COF3-CZ11*COD3*SIF3)/SID1
16154       COD2=CX22*COD3+CZ22*SID3
16155       SID2=SQRT((ONEONE-COD2)*(ONEONE+COD2))
16156       COF2=(CX22*SID3*COF3-CY22*SIF3-CZ22*COD3*COF3)/SID2
16157       SIF2=(CX22*SID3*SIF3+CY22*COF3-CZ22*COD3*SIF3)/SID2
16158  400  CONTINUE
16159 * === Energy conservation check: === *
16160       EOCHCK = UMO - ECM1 - ECM2 - ECM3
16161 *     SID1 = SQRT ( ( ONEONE - COD1 ) * ( ONEONE + COD1 ) )
16162 *     SID2 = SQRT ( ( ONEONE - COD2 ) * ( ONEONE + COD2 ) )
16163 *     SID3 = SQRT ( ( ONEONE - COD3 ) * ( ONEONE + COD3 ) )
16164       PZCHCK = PCM1 * COD1 + PCM2 * COD2 + PCM3 * COD3
16165       PXCHCK = PCM1 * COF1 * SID1 + PCM2 * COF2 * SID2
16166      &       + PCM3 * COF3 * SID3
16167       PYCHCK = PCM1 * SIF1 * SID1 + PCM2 * SIF2 * SID2
16168      &       + PCM3 * SIF3 * SID3
16169       EOCMPR = 1.D-12 * UMO
16170       IF ( ABS (EOCHCK) + ABS (PXCHCK) + ABS (PYCHCK) + ABS (PZCHCK)
16171      &     .GT. EOCMPR ) THEN
16172 **sr 5.5.95 output-unit changed
16173          IF (IOULEV(1).GT.0) THEN
16174             WRITE(LOUT,*)
16175      &      ' *** Threpd: energy/momentum conservation failure! ***',
16176      &      EOCHCK,PXCHCK,PYCHCK,PZCHCK
16177             WRITE(LOUT,*)' *** SID1,SID2,SID3',SID1,SID2,SID3
16178          ENDIF
16179 **
16180       END IF
16181       RETURN
16182       END
16183
16184 *$ CREATE DT_DBKLAS.FOR
16185 *COPY DT_DBKLAS
16186 *
16187 *===dbklas=============================================================*
16188 *
16189       SUBROUTINE DT_DBKLAS(I,J,K,I8,I10)
16190
16191       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16192       SAVE
16193
16194       PARAMETER ( LINP = 10 ,
16195      &            LOUT = 6 ,
16196      &            LDAT = 9 )
16197
16198 * quark-content to particle index conversion (DTUNUC 1.x)
16199       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16200      &                IA08(6,21),IA10(6,21)
16201
16202       IF (I) 20,20,10
16203 * baryons
16204    10 CONTINUE
16205       CALL DT_INDEXD(J,K,IND)
16206       I8  = IB08(I,IND)
16207       I10 = IB10(I,IND)
16208       IF (I8.LE.0) I8 = I10
16209       RETURN
16210 * antibaryons
16211    20 CONTINUE
16212       II = IABS(I)
16213       JJ = IABS(J)
16214       KK = IABS(K)
16215       CALL DT_INDEXD(JJ,KK,IND)
16216       I8  = IA08(II,IND)
16217       I10 = IA10(II,IND)
16218       IF (I8.LE.0) I8 = I10
16219
16220       RETURN
16221       END
16222
16223 *$ CREATE DT_INDEXD.FOR
16224 *COPY DT_INDEXD
16225 *
16226 *===indexd=============================================================*
16227 *
16228       SUBROUTINE DT_INDEXD(KA,KB,IND)
16229
16230       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16231       SAVE
16232
16233       PARAMETER ( LINP = 10 ,
16234      &            LOUT = 6 ,
16235      &            LDAT = 9 )
16236
16237       KP = KA*KB
16238       KS = KA+KB
16239       IF (KP.EQ.1) IND=1
16240       IF (KP.EQ.2) IND=2
16241       IF (KP.EQ.3) IND=3
16242       IF ((KP.EQ.4).AND.(KS.EQ.5)) IND=4
16243       IF (KP.EQ.5) IND=5
16244       IF ((KP.EQ.6).AND.(KS.EQ.7)) IND=6
16245       IF ((KP.EQ.4).AND.(KS.EQ.4)) IND=7
16246       IF ((KP.EQ.6).AND.(KS.EQ.5)) IND=8
16247       IF (KP.EQ.8)  IND=9
16248       IF (KP.EQ.10) IND=10
16249       IF ((KP.EQ.12).AND.(KS.EQ.8)) IND=11
16250       IF (KP.EQ.9)  IND=12
16251       IF ((KP.EQ.12).AND.(KS.EQ.7)) IND=13
16252       IF (KP.EQ.15) IND=14
16253       IF (KP.EQ.18) IND=15
16254       IF (KP.EQ.16) IND=16
16255       IF (KP.EQ.20) IND=17
16256       IF (KP.EQ.24) IND=18
16257       IF (KP.EQ.25) IND=19
16258       IF (KP.EQ.30) IND=20
16259       IF (KP.EQ.36) IND=21
16260
16261       RETURN
16262       END
16263
16264 *$ CREATE DT_DCHANT.FOR
16265 *COPY DT_DCHANT
16266 *
16267 *===dchant=============================================================*
16268 *
16269       SUBROUTINE DT_DCHANT
16270
16271       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16272       SAVE
16273
16274       PARAMETER ( LINP = 10 ,
16275      &            LOUT = 6 ,
16276      &            LDAT = 9 )
16277
16278       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16279
16280 * HADRIN: decay channel information
16281       PARAMETER (IDMAX9=602)
16282       CHARACTER*8 ZKNAME
16283       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
16284
16285 * particle properties (BAMJET index convention)
16286       CHARACTER*8  ANAME
16287       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
16288      &                IICH(210),IIBAR(210),K1(210),K2(210)
16289
16290       DIMENSION HWT(IDMAX9)
16291
16292 * change of weights wt from absolut values into the sum of wt of a dec.
16293       DO 10 J=1,IDMAX9
16294          HWT(J) = ZERO
16295    10 CONTINUE
16296 C     DO 999 KKK=1,210
16297 C        WRITE(LOUT,'(A8,F5.2,2E10.3,2I4,2I10)')
16298 C    &      ANAME(KKK),AAM(KKK),GA(KKK),TAU(KKK),IICH(KKK),IIBAR(KKK),
16299 C    &      K1(KKK),K2(KKK)
16300 C 999 CONTINUE
16301 C     STOP
16302       DO 30 I=1,210
16303          IK1 = K1(I)
16304          IK2 = K2(I)
16305          HV  = ZERO
16306          DO 20 J=IK1,IK2
16307             HV     = HV+WT(J)
16308             HWT(J) = HV
16309 **sr 13.1.95
16310             IF (HWT(J).GT.1.0001) WRITE(LOUT,1000) HWT(J),J,I,IK1
16311  1000       FORMAT(2X,15H ERROR IN HWT =,1F10.5,8H J,I,K1=,3I5)
16312    20    CONTINUE
16313    30 CONTINUE
16314       DO 40 J=1,IDMAX9
16315          WT(J) = HWT(J)
16316    40 CONTINUE
16317
16318       RETURN
16319       END
16320
16321 *$ CREATE DT_DDATAR.FOR
16322 *COPY DT_DDATAR
16323 *
16324 *===ddatar=============================================================*
16325 *
16326       SUBROUTINE DT_DDATAR
16327
16328       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16329       SAVE
16330
16331       PARAMETER ( LINP = 10 ,
16332      &            LOUT = 6 ,
16333      &            LDAT = 9 )
16334
16335       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16336
16337 * quark-content to particle index conversion (DTUNUC 1.x)
16338       COMMON /DTQ2ID/ IMPS(6,6),IMVE(6,6),IB08(6,21),IB10(6,21),
16339      &                IA08(6,21),IA10(6,21)
16340
16341       DIMENSION IV(36),IP(36),IB(126),IBB(126),IA(126),IAA(126)
16342
16343       DATA IV/ 33, 34, 38,123,  0,  0, 32, 33, 39,124,
16344      &          0,  0, 36, 37, 96,127,  0,  0,126,125,
16345      &        128,129,14*0/
16346       DATA IP/ 23, 14, 16,116,  0,  0, 13, 23, 25,117,
16347      &          0,  0, 15, 24, 31,120,  0,  0,119,118,
16348      &        121,122,14*0/
16349       DATA IB/  0,  1, 21,140,  0,  0,  8, 22,137,  0,
16350      &          0, 97,138,  0,  0,146,  0,  0,  0,  0,
16351      &          0,  1,  8, 22,137,  0,  0,  0, 20,142,
16352      &          0,  0, 98,139,  0,  0,147,  0,  0,  0,
16353      &          0,  0, 21, 22, 97,138,  0,  0, 20, 98,
16354      &        139,  0,  0,  0,145,  0,  0,148,  0,  0,
16355      &          0,  0,  0,140,137,138,146,  0,  0,142,
16356      &        139,147,  0,  0,145,148,           50*0/
16357       DATA IBB/53, 54,104,161,  0,  0, 55,105,162,  0,
16358      &          0,107,164,  0,  0,167,  0,  0,  0,  0,
16359      &          0, 54, 55,105,162,  0,  0, 56,106,163,
16360      &          0,  0,108,165,  0,  0,168,  0,  0,  0,
16361      &          0,  0,104,105,107,164,  0,  0,106,108,
16362      &        165,  0,  0,109,166,  0,  0,169,  0,  0,
16363      &          0,  0,  0,161,162,164,167,  0,  0,163,
16364      &        165,168,  0,  0,166,169,  0,  0,170,47*0/
16365       DATA IA/  0,  2, 99,152,  0,  0,  9,100,149,  0,
16366      &          0,102,150,  0,  0,158,  0,  0,  0,  0,
16367      &          0,  2,  9,100,149,  0,  0,  0,101,154,
16368      &          0,  0,103,151,  0,  0,159,  0,  0,  0,
16369      &          0,  0, 99,100,102,150,  0,  0,101,103,
16370      &        151,  0,  0,  0,157,  0,  0,160,  0,  0,
16371      &          0,  0,  0,152,149,150,158,  0,  0,154,
16372      &        151,159,  0,  0,157,160,           50*0/
16373       DATA IAA/67, 68,110,171,  0,  0, 69,111,172,  0,
16374      &          0,113,174,  0,  0,177,  0,  0,  0,  0,
16375      &          0, 68, 69,111,172,  0,  0, 70,112,173,
16376      &          0,  0,114,175,  0,  0,178,  0,  0,  0,
16377      &          0,  0,110,111,113,174,  0,  0,112,114,
16378      &        175,  0,  0,115,176,  0,  0,179,  0,  0,
16379      &          0,  0,  0,171,172,174,177,  0,  0,173,
16380      &        175,178,  0,  0,176,179,  0,  0,180,47*0/
16381
16382       L=0
16383       DO 2 I=1,6
16384          DO 1 J=1,6
16385             L = L+1
16386             IMPS(I,J) = IP(L)
16387             IMVE(I,J) = IV(L)
16388     1    CONTINUE
16389     2 CONTINUE
16390       L=0
16391       DO 4 I=1,6
16392          DO 3 J=1,21
16393             L = L+1
16394             IB08(I,J) = IB(L)
16395             IB10(I,J) = IBB(L)
16396             IA08(I,J) = IA(L)
16397             IA10(I,J) = IAA(L)
16398     3    CONTINUE
16399     4 CONTINUE
16400 C     A1  = 0.88D0
16401 C     B1  = 3.0D0
16402 C     B2  = 3.0D0
16403 C     B3  = 8.0D0
16404 C     LT  = 0
16405 C     LB  = 0
16406 C     BET = 12.0D0
16407 C     AS  = 0.25D0
16408 C     B8  = 0.33D0
16409 C     AME = 0.95D0
16410 C     DIQ = 0.375D0
16411 C     ISU = 4
16412
16413       RETURN
16414       END
16415
16416 *$ CREATE DT_INITJS.FOR
16417 *COPY DT_INITJS
16418 *
16419 *===initjs=============================================================*
16420 *
16421       SUBROUTINE DT_INITJS(MODE)
16422
16423 ************************************************************************
16424 * Initialize JETSET paramters.                                         *
16425 *           MODE = 0 default settings                                  *
16426 *                = 1 PHOJET settings                                   *
16427 *                = 2 DTUNUC settings                                   *
16428 * This version dated 16.02.96 is written by S. Roesler                 *
16429 *                                                                      *
16430 * Last change 27.12.2006 by S. Roesler.                                *
16431 ************************************************************************
16432
16433       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16434       SAVE
16435
16436       PARAMETER ( LINP = 10 ,
16437      &            LOUT = 6 ,
16438      &            LDAT = 9 )
16439
16440       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
16441
16442       LOGICAL LFIRST,LFIRDT,LFIRPH
16443
16444 *      INCLUDE '(DIMPAR)'
16445 *     DIMPAR taken from FLUKA
16446       PARAMETER ( MXXRGN =20000 )
16447       PARAMETER ( MXXMDF =  710 )
16448       PARAMETER ( MXXMDE =  702 )
16449       PARAMETER ( MFSTCK =40000 )
16450       PARAMETER ( MESTCK =  100 )
16451       PARAMETER ( MOSTCK = 2000 )
16452       PARAMETER ( MXPRSN =  100 )
16453       PARAMETER ( MXPDPM =  800 )
16454       PARAMETER ( MXPSCS =30000 )
16455       PARAMETER ( MXGLWN =  300 )
16456       PARAMETER ( MXOUTU =   50 )
16457       PARAMETER ( NALLWP =   64 )
16458       PARAMETER ( NELEMX =   80 )
16459       PARAMETER ( MPDPDX =   18 )
16460       PARAMETER ( MXHTTR =  260 )
16461       PARAMETER ( MXSEAX =   20 )
16462       PARAMETER ( MXHTNC = MXSEAX + 1 )
16463       PARAMETER ( ICOMAX = 2400 )
16464       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
16465       PARAMETER ( NSTBIS =  304 )
16466       PARAMETER ( NQSTIS =   46 )
16467       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
16468       PARAMETER ( MXPABL =  120 )
16469       PARAMETER ( IDMAXP =  450 )
16470       PARAMETER ( IDMXDC = 2000 )
16471       PARAMETER ( MXMCIN =  410 )
16472       PARAMETER ( IHYPMX =    4 )
16473       PARAMETER ( MKBMX1 =   11 )
16474       PARAMETER ( MKBMX2 =   11 )
16475       PARAMETER ( MXIRRD = 2500 )
16476       PARAMETER ( MXTRDC = 1500 )
16477       PARAMETER ( NKTL   =   17 )
16478       PARAMETER ( NBLNMX = 40000000 )
16479
16480 *      INCLUDE '(PART)'
16481 *     PART taken from FLUKA
16482       PARAMETER ( KPETA0 =  31 )
16483       PARAMETER ( KPRHOP =  32 )
16484       PARAMETER ( KPRHO0 =  33 )
16485       PARAMETER ( KPRHOM =  34 )
16486       PARAMETER ( KPOME0 =  35 )
16487       PARAMETER ( KPPHI0 =  96 )
16488       PARAMETER ( KPDEPP =  53 )
16489       PARAMETER ( KPDELP =  54 )
16490       PARAMETER ( KPDEL0 =  55 )
16491       PARAMETER ( KPDELM =  56 )
16492       PARAMETER ( KPN14P =  91 )
16493       PARAMETER ( KPN140 =  92 )
16494 *  Low mass diffraction partners:
16495       PARAMETER ( KDETA0 =   0 )
16496       PARAMETER ( KDRHOP =   0 )
16497       PARAMETER ( KDRHO0 = 210 )
16498       PARAMETER ( KDRHOM =   0 )
16499       PARAMETER ( KDOME0 = 210 )
16500       PARAMETER ( KDPHI0 = 210 )
16501       PARAMETER ( KDDEPP =   0 )
16502       PARAMETER ( KDDELP =   0 )
16503       PARAMETER ( KDDEL0 =   0 )
16504       PARAMETER ( KDDELM =   0 )
16505       PARAMETER ( KDN14P =   0 )
16506       PARAMETER ( KDN140 =   0 )
16507 *
16508       CHARACTER*8  ANAME
16509       COMMON / PART /  AM     (-6:IDMAXP), GA     (-6:IDMAXP),
16510      &                 TAU    (-6:IDMAXP), AMDISC (-6:IDMAXP),
16511      &                 ZMNABS (-6:IDMAXP), ATNMNA (-6:IDMAXP),
16512      &                 ATXN14,     ATMN14, RNRN14    (-10:10),
16513      &                 ICH    (-6:IDMAXP), IBAR   (-6:IDMAXP),
16514      &                 ISOSYM (-6:IDMAXP), ICHCON (-6:IDMAXP),
16515      &                 K1     (-6:IDMAXP), K2     (-6:IDMAXP),
16516      &                 KPTOIP (-6:IDMAXP), IPTOKP (-6:NALLWP),
16517      &                 KPTOIA (-6:IDMAXP), IATOKP (-6:MXPABL),
16518      &                 IDCFLG (-6:NALLWP), IPTYPE (-6:NALLWP)
16519
16520       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16521       COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16522       COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16523
16524 * flags for particle decays
16525       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
16526      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
16527      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
16528
16529 * flags for input different options
16530       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16531       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16532      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16533
16534       INTEGER PYCOMP
16535
16536       DIMENSION IDXSTA(40)
16537       DATA IDXSTA
16538 *          K0s   pi0  lam   alam  sig+  asig+ sig-  asig- tet0  atet0
16539      &  /  310,  111, 3122,-3122, 3222,-3222, 3112,-3112, 3322,-3322,
16540 *          tet- atet-  om-  aom-   D+    D-    D0    aD0   Ds+   aDs+
16541      &    3312,-3312, 3334,-3334,  411, -411,  421, -421,  431, -431,
16542 *          etac lamc+alamc+sigc++ sigc+ sigc0asigc++asigc+asigc0 Ksic+
16543      &     441, 4122,-4122, 4222, 4212, 4112,-4222,-4212,-4112, 4232,
16544 *         Ksic0 aKsic+aKsic0 sig0 asig0
16545      &    4132,-4232,-4132, 3212,-3212, 5*0/
16546
16547       DATA LFIRST,LFIRDT,LFIRPH /.TRUE.,.TRUE.,.TRUE./
16548
16549       IF (LFIRST) THEN
16550 * save default settings
16551          PDEF1  = PARJ(1)
16552          PDEF2  = PARJ(2)
16553          PDEF3  = PARJ(3)
16554          PDEF5  = PARJ(5)
16555          PDEF6  = PARJ(6)
16556          PDEF7  = PARJ(7)
16557          PDEF18 = PARJ(18)
16558          PDEF19 = PARJ(19)
16559          PDEF21 = PARJ(21)
16560          PDEF42 = PARJ(42)
16561          MDEF12 = MSTJ(12)
16562 * LUJETS / PYJETS array-dimensions
16563
16564          MSTU(4) = 4000
16565
16566 * increase maximum number of JETSET-error prints
16567          MSTU(22) = 50000
16568 * prevent particles decaying
16569          DO 1 I=1,35
16570             IF (I.LT.34) THEN
16571
16572                KC = PYCOMP(IDXSTA(I))
16573
16574                IF (KC.GT.0) THEN
16575                   IF (I.EQ.2) THEN
16576 *  pi0 decay
16577 C                    MDCY(KC,1) = 1
16578                      MDCY(KC,1) = 0
16579 **cr mode
16580 C                 ELSEIF ((I.EQ.4).OR.(I.EQ. 6).OR.
16581 C   &                    (I.EQ.8).OR.(I.EQ.10)) THEN
16582 C                 ELSEIF (I.EQ.4) THEN
16583 C                    MDCY(KC,1) = 1
16584 **
16585                   ELSE
16586                      MDCY(KC,1) = 0
16587                   ENDIF
16588                ENDIF
16589             ELSEIF (((I.EQ.34).OR.(I.EQ.35)).AND.(ISIG0.EQ.0)) THEN
16590
16591                KC = PYCOMP(IDXSTA(I))
16592
16593                IF (KC.GT.0) THEN
16594                   MDCY(KC,1) = 0
16595                ENDIF
16596             ENDIF
16597     1    CONTINUE
16598 *
16599
16600 * as Fluka event-generator: allow only paprop particles to be stable
16601 * and let all other particles decay (i.e. those with strong decays)
16602          IF (ITRSPT.EQ.1) THEN
16603             DO 5 I=1,IDMAXP
16604                IF (KPTOIP(I).NE.0) THEN
16605                   IDPDG = MPDGHA(I)
16606
16607                   KC    = PYCOMP(IDPDG)
16608
16609                   IF (KC.GT.0) THEN
16610                      IF (MDCY(KC,1).EQ.1) THEN
16611                         WRITE(LOUT,*)
16612      &                     ' DT_INITJS: Decay flag for FLUKA-',
16613      &                     'transport : particle should not ',
16614      &                     'decay : ',IDPDG,'  ',ANAME(I)
16615                         MDCY(KC,1) = 0
16616                      ENDIF
16617                   ENDIF
16618                ENDIF
16619     5       CONTINUE
16620             DO 6 KC=1,500
16621                IDPDG = KCHG(KC,4)
16622                KP    = MCIHAD(IDPDG)
16623                IF (KP.GT.0) THEN
16624                   IF ((MDCY(KC,1).EQ.0).AND.(KPTOIP(KP).EQ.0).AND.
16625      &                (ANAME(KP).NE.'BLANK   ').AND.
16626      &                (ANAME(KP).NE.'RNDFLV  ')) THEN
16627                      WRITE(LOUT,*) ' DT_INITJS: Decay flag for FLUKA-',
16628      &                             'transport: particle should decay ',
16629      &                             ': ',IDPDG,' ',ANAME(KP)
16630                      MDCY(KC,1) = 1
16631                   ENDIF
16632                ENDIF
16633     6       CONTINUE
16634          ENDIF
16635
16636 *
16637 * popcorn:
16638          IF (PDB.LE.ZERO) THEN
16639 *   no popcorn-mechanism
16640             MSTJ(12) = 1
16641          ELSE
16642             MSTJ(12) = 3
16643             PARJ(5)  = PDB
16644          ENDIF
16645 * set JETSET-parameter requested by input cards
16646          IF (NMSTU.GT.0) THEN
16647             DO 2 I=1,NMSTU
16648                MSTU(IMSTU(I)) = MSTUX(I)
16649     2       CONTINUE
16650          ENDIF
16651          IF (NMSTJ.GT.0) THEN
16652             DO 3 I=1,NMSTJ
16653                MSTJ(IMSTJ(I)) = MSTJX(I)
16654     3       CONTINUE
16655          ENDIF
16656          IF (NPARU.GT.0) THEN
16657             DO 4 I=1,NPARU
16658                PARU(IPARU(I)) = PARUX(I)
16659     4       CONTINUE
16660          ENDIF
16661          LFIRST = .FALSE.
16662       ENDIF
16663 *
16664 * PARJ(1)  suppression of qq-aqaq pair prod. compared to
16665 *          q-aq pair prod.                      (default: 0.1)
16666 * PARJ(2)  strangeness suppression               (default: 0.3)
16667 * PARJ(3)  extra suppression of strange diquarks (default: 0.4)
16668 * PARJ(6)  extra suppression of sas-pair shared by B and
16669 *          aB in BMaB                           (default: 0.5)
16670 * PARJ(7)  extra suppression of strange meson M in BMaB
16671 *          configuration                        (default: 0.5)
16672 * PARJ(18) spin 3/2 baryon suppression           (default: 1.0)
16673 * PARJ(21) width sigma in Gaussian p_x, p_y transverse
16674 *          momentum distrib. for prim. hadrons  (default: 0.35)
16675 * PARJ(42) b-parameter for symmetric Lund-fragmentation
16676 *          function                             (default: 0.9 GeV^-2)
16677 *
16678 * PHOJET settings
16679       IF (MODE.EQ.1) THEN
16680 *   JETSET default
16681 C        PARJ(1)  = PDEF1
16682 C        PARJ(2)  = PDEF2
16683 C        PARJ(3)  = PDEF3
16684 C        PARJ(6)  = PDEF6
16685 C        PARJ(7)  = PDEF7
16686 C        PARJ(18) = PDEF18
16687 C        PARJ(21) = PDEF21
16688 C        PARJ(42) = PDEF42
16689 **sr 18.11.98 parameter tuning
16690 C        PARJ(1)  = 0.092D0
16691 C        PARJ(2)  = 0.25D0
16692 C        PARJ(3)  = 0.45D0
16693 C        PARJ(19) = 0.3D0
16694 C        PARJ(21) = 0.45D0
16695 C        PARJ(42) = 1.0D0
16696 **sr 28.04.99 parameter tuning (May 99 minor modifications)
16697          PARJ(1)  = 0.085D0
16698          PARJ(2)  = 0.26D0
16699          PARJ(3)  = 0.8D0
16700          PARJ(11) = 0.38D0
16701          PARJ(18) = 0.3D0
16702          PARJ(19) = 0.4D0
16703          PARJ(21) = 0.36D0
16704          PARJ(41) = 0.3D0
16705          PARJ(42) = 0.86D0
16706          IF (NPARJ.GT.0) THEN
16707             DO 10 I=1,NPARJ
16708                IF (IPARJ(I).GT.0) PARJ(IPARJ(I)) = PARJX(I)
16709    10       CONTINUE
16710          ENDIF
16711          IF (LFIRPH) THEN
16712             WRITE(LOUT,'(1X,A)')
16713      &         'DT_INITJS: JETSET-parameter for PHOJET'
16714             CALL DT_JSPARA(0)
16715             LFIRPH = .FALSE.
16716          ENDIF
16717 * DTUNUC settings
16718       ELSEIF (MODE.EQ.2) THEN
16719          IF (IFRAG(2).EQ.1) THEN
16720 **sr parameters before 9.3.96
16721 C           PARJ(2)  = 0.27D0
16722 C           PARJ(3)  = 0.6D0
16723 C           PARJ(6)  = 0.75D0
16724 C           PARJ(7)  = 0.75D0
16725 C           PARJ(21) = 0.55D0
16726 C           PARJ(42) = 1.3D0
16727 **sr 18.11.98 parameter tuning
16728 C           PARJ(1)  = 0.05D0
16729 C           PARJ(2)  = 0.27D0
16730 C           PARJ(3)  = 0.4D0
16731 C           PARJ(19) = 0.2D0
16732 C           PARJ(21) = 0.45D0
16733 C           PARJ(42) = 1.0D0
16734 **sr 28.04.99 parameter tuning
16735             PARJ(1)  = 0.11D0
16736             PARJ(2)  = 0.36D0
16737             PARJ(3)  = 0.8D0
16738             PARJ(19) = 0.2D0
16739             PARJ(21) = 0.3D0
16740             PARJ(41) = 0.3D0
16741             PARJ(42) = 0.58D0
16742             IF (NPARJ.GT.0) THEN
16743                DO 20 I=1,NPARJ
16744                   IF (IPARJ(I).LT.0) THEN
16745                      IDX = ABS(IPARJ(I))
16746                      PARJ(IDX) = PARJX(I)
16747                   ENDIF
16748    20          CONTINUE
16749             ENDIF
16750             IF (LFIRDT) THEN
16751                WRITE(LOUT,'(1X,A)')
16752      &           'DT_INITJS: JETSET-parameter for DTUNUC'
16753                CALL DT_JSPARA(0)
16754                LFIRDT = .FALSE.
16755             ENDIF
16756          ELSEIF (IFRAG(2).EQ.2) THEN
16757             PARJ(1)  = 0.11D0
16758             PARJ(2)  = 0.27D0
16759             PARJ(3)  = 0.3D0
16760             PARJ(6)  = 0.35D0
16761             PARJ(7)  = 0.45D0
16762             PARJ(18) = 0.66D0
16763 C           PARJ(21) = 0.55D0
16764 C           PARJ(42) = 1.0D0
16765             PARJ(21) = 0.60D0
16766             PARJ(42) = 1.3D0
16767          ELSE
16768             PARJ(1)  = PDEF1
16769             PARJ(2)  = PDEF2
16770             PARJ(3)  = PDEF3
16771             PARJ(6)  = PDEF6
16772             PARJ(7)  = PDEF7
16773             PARJ(18) = PDEF18
16774             PARJ(21) = PDEF21
16775             PARJ(42) = PDEF42
16776          ENDIF
16777       ELSE
16778          PARJ(1)  = PDEF1
16779          PARJ(2)  = PDEF2
16780          PARJ(3)  = PDEF3
16781          PARJ(5)  = PDEF5
16782          PARJ(6)  = PDEF6
16783          PARJ(7)  = PDEF7
16784          PARJ(18) = PDEF18
16785          PARJ(19) = PDEF19
16786          PARJ(21) = PDEF21
16787          PARJ(42) = PDEF42
16788          MSTJ(12) = MDEF12
16789       ENDIF
16790
16791       RETURN
16792       END
16793
16794 *$ CREATE DT_JSPARA.FOR
16795 *COPY DT_JSPARA
16796 *
16797 *===jspara=============================================================*
16798 *
16799       SUBROUTINE DT_JSPARA(MODE)
16800
16801       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16802       SAVE
16803
16804       PARAMETER ( LINP = 10 ,
16805      &            LOUT = 6 ,
16806      &            LDAT = 9 )
16807
16808       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,TINY1=1.0D-1,
16809      &           ONE=1.0D0,ZERO=0.0D0)
16810
16811       LOGICAL LFIRST
16812
16813       COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16814
16815       DIMENSION ISTU(200),QARU(200),ISTJ(200),QARJ(200)
16816
16817       DATA LFIRST /.TRUE./
16818
16819 * save the default JETSET-parameter on the first call
16820       IF (LFIRST) THEN
16821          DO 1 I=1,200
16822             ISTU(I) = MSTU(I)
16823             QARU(I) = PARU(I)
16824             ISTJ(I) = MSTJ(I)
16825             QARJ(I) = PARJ(I)
16826     1    CONTINUE
16827          LFIRST = .FALSE.
16828       ENDIF
16829
16830       WRITE(LOUT,1000)
16831  1000 FORMAT(1X,'DT_JSPARA: new value (default value)')
16832
16833 * compare the default JETSET-parameter with the present values
16834       DO 2 I=1,200
16835          IF ((MSTU(I).NE.ISTU(I)).AND.(I.NE.31)) THEN
16836             WRITE(LOUT,1002) 'MSTU(',I,MSTU(I),ISTU(I)
16837 C           ISTU(I) = MSTU(I)
16838          ENDIF
16839          DIFF = ABS(PARU(I)-QARU(I))
16840          IF ((DIFF.GE.1.0D-5).AND.(I.NE.21)) THEN
16841             WRITE(LOUT,1001) 'PARU(',I,PARU(I),QARU(I)
16842 C           QARU(I) = PARU(I)
16843          ENDIF
16844          IF (MSTJ(I).NE.ISTJ(I)) THEN
16845             WRITE(LOUT,1002) 'MSTJ(',I,MSTJ(I),ISTJ(I)
16846 C           ISTJ(I) = MSTJ(I)
16847          ENDIF
16848          DIFF = ABS(PARJ(I)-QARJ(I))
16849          IF (DIFF.GE.1.0D-5) THEN
16850             WRITE(LOUT,1001) 'PARJ(',I,PARJ(I),QARJ(I)
16851 C           QARJ(I) = PARJ(I)
16852          ENDIF
16853     2 CONTINUE
16854  1001 FORMAT(12X,A5,I3,'): ',F6.3,' (',F6.3,')')
16855  1002 FORMAT(12X,A5,I3,'): ',I6,' (',I6,')')
16856
16857       RETURN
16858       END
16859 *$ CREATE DT_FOZOCA.FOR
16860 *COPY DT_FOZOCA
16861 *
16862 *===fozoca=============================================================*
16863 *
16864       SUBROUTINE DT_FOZOCA(LFZC,IREJ)
16865
16866 ************************************************************************
16867 * This subroutine treats the complete FOrmation ZOne supressed intra-  *
16868 * nuclear CAscade.                                                     *
16869 *               LFZC = .true.  cascade has been treated                *
16870 *                    = .false. cascade skipped                         *
16871 * This is a completely revised version of the original FOZOKL.         *
16872 * This version dated 18.11.95 is written by S. Roesler                 *
16873 ************************************************************************
16874
16875       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
16876       SAVE
16877
16878       PARAMETER ( LINP = 10 ,
16879      &            LOUT = 6 ,
16880      &            LDAT = 9 )
16881
16882       PARAMETER (DLARGE=1.0D10,OHALF=0.5D0,ZERO=0.0D0)
16883       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
16884
16885       LOGICAL LSTART,LCAS,LFZC
16886
16887 * event history
16888
16889       PARAMETER (NMXHKK=200000)
16890
16891       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
16892      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
16893      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
16894
16895 * extended event history
16896       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
16897      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
16898      &                IHIST(2,NMXHKK)
16899
16900 * rejection counter
16901       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
16902      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
16903      &                IREXCI(3),IRDIFF(2),IRINC
16904
16905 * properties of interacting particles
16906       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
16907
16908 * Glauber formalism: collision properties
16909       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
16910      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
16911
16912 * flags for input different options
16913       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
16914       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
16915      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
16916
16917 * final state after intranuclear cascade step
16918       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
16919
16920 * parameter for intranuclear cascade
16921       LOGICAL LPAULI
16922       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
16923
16924       DIMENSION NCWOUN(2)
16925
16926       DATA LSTART /.TRUE./
16927
16928       LFZC = .TRUE.
16929       IREJ = 0
16930
16931 * skip cascade if hadron-hadron interaction or if supressed by user
16932       IF (((IP.EQ.1).AND.(IT.EQ.1)).OR.(KTAUGE.LT.1)) GOTO 9999
16933 * skip cascade if not all possible chains systems are hadronized
16934       DO 1 I=1,8
16935          IF (.NOT.LHADRO(I)) GOTO 9999
16936     1 CONTINUE
16937
16938       IF (LSTART) THEN
16939          WRITE(LOUT,1000) KTAUGE,TAUFOR,INCMOD
16940  1000    FORMAT(/,1X,'FOZOCA:  intranuclear cascade treated for a ',
16941      &          'maximum of',I4,' generations',/,10X,'formation time ',
16942      &          'parameter:',F5.1,'  fm/c',9X,'modus:',I2)
16943          IF (ITAUVE.EQ.1) WRITE(LOUT,1001)
16944          IF (ITAUVE.EQ.2) WRITE(LOUT,1002)
16945  1001    FORMAT(10X,'p_t dependent formation zone',/)
16946  1002    FORMAT(10X,'constant formation zone',/)
16947          LSTART = .FALSE.
16948       ENDIF
16949
16950 * in order to avoid wasting of cpu-time the DTEVT1-indices of nucleons
16951 * which may interact with final state particles are stored in a seperate
16952 * array - here all proj./target nucleon-indices (just for simplicity)
16953       NOINC = 0
16954       DO 9 I=1,NPOINT(1)-1
16955          NOINC = NOINC+1
16956          IDXINC(NOINC) = I
16957     9 CONTINUE
16958
16959 * initialize Pauli-principle treatment (find wounded nucleons)
16960       NWOUND(1) = 0
16961       NWOUND(2) = 0
16962       NCWOUN(1) = 0
16963       NCWOUN(2) = 0
16964       DO 2 J=1,NPOINT(1)
16965          DO 3 I=1,2
16966             IF (ISTHKK(J).EQ.10+I) THEN
16967                NWOUND(I) = NWOUND(I)+1
16968                EWOUND(I,NWOUND(I)) = PHKK(4,J)
16969                IF (IDHKK(J).EQ.2212) NCWOUN(I) = NCWOUN(I)+1
16970             ENDIF
16971     3    CONTINUE
16972     2 CONTINUE
16973
16974 * modify nuclear potential for wounded nucleons
16975       IPRCL  = IP -NWOUND(1)
16976       IPZRCL = IPZ-NCWOUN(1)
16977       ITRCL  = IT -NWOUND(2)
16978       ITZRCL = ITZ-NCWOUN(2)
16979       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
16980
16981       NSTART = NPOINT(4)
16982       NEND   = NHKK
16983
16984     7 CONTINUE
16985       DO 8 I=NSTART,NEND
16986
16987          IF ((ABS(ISTHKK(I)).EQ.1).AND.(IDCH(I).LT.KTAUGE)) THEN
16988 * select nucleus the cascade starts first (proj. - 1, target - -1)
16989             NCAS   = 1
16990 *   projectile/target with probab. 1/2
16991             IF ((INCMOD.EQ.1).OR.(IDCH(I).GT.0)) THEN
16992                IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16993 *   in the nucleus with highest mass
16994             ELSEIF (INCMOD.EQ.2) THEN
16995                IF (IP.GT.IT) THEN
16996                   NCAS = -NCAS
16997                ELSEIF (IP.EQ.IT) THEN
16998                   IF (DT_RNDM(TAUFOR).GT.OHALF) NCAS = -NCAS
16999                ENDIF
17000 * the nucleus the cascade starts first is requested to be the one
17001 * moving in the direction of the secondary
17002             ELSEIF (INCMOD.EQ.3) THEN
17003                NCAS = INT(SIGN(1.0D0,PHKK(3,I)))
17004             ENDIF
17005 * check that the selected "nucleus" is not a hadron
17006             IF (((NCAS.EQ. 1).AND.(IP.LE.1)).OR.
17007      &          ((NCAS.EQ.-1).AND.(IT.LE.1)))    NCAS = -NCAS
17008
17009 * treat intranuclear cascade in the nucleus selected first
17010             LCAS = .FALSE.
17011             CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17012             IF (IREJ1.NE.0) GOTO 9998
17013 * treat intranuclear cascade in the other nucleus if this isn't a had.
17014             NCAS = -NCAS
17015             IF (((NCAS.EQ. 1).AND.(IP.GT.1)).OR.
17016      &          ((NCAS.EQ.-1).AND.(IT.GT.1)))    THEN
17017                IF (LCAS) CALL DT_INUCAS(IT,IP,I,LCAS,NCAS,IREJ1)
17018                IF (IREJ1.NE.0) GOTO 9998
17019             ENDIF
17020
17021          ENDIF
17022
17023     8 CONTINUE
17024       NSTART = NEND+1
17025       NEND   = NHKK
17026       IF (NSTART.LE.NEND) GOTO 7
17027
17028       RETURN
17029
17030  9998 CONTINUE
17031 * reject this event
17032       IRINC = IRINC+1
17033       IREJ = 1
17034
17035  9999 CONTINUE
17036 * intranucl. cascade not treated because of interaction properties or
17037 * it is supressed by user or it was rejected or...
17038       LFZC = .FALSE.
17039 * reset flag characterizing direction of motion in n-n-cms
17040 **sr14-11-95
17041 C     DO 9990 I=NPOINT(5),NHKK
17042 C        IF (ISTHKK(I).EQ.-1) ISTHKK(I)=1
17043 C9990 CONTINUE
17044
17045       RETURN
17046       END
17047
17048 *$ CREATE DT_INUCAS.FOR
17049 *COPY DT_INUCAS
17050 *
17051 *===inucas=============================================================*
17052 *
17053       SUBROUTINE DT_INUCAS(IT,IP,IDXCAS,LCAS,NCAS,IREJ)
17054
17055 ************************************************************************
17056 * Formation zone supressed IntraNUclear CAScade for one final state    *
17057 * particle.                                                            *
17058 *           IT, IP    mass numbers of target, projectile nuclei        *
17059 *           IDXCAS    index of final state particle in DTEVT1          *
17060 *           NCAS =  1 intranuclear cascade in projectile               *
17061 *                = -1 intranuclear cascade in target                   *
17062 * This version dated 18.11.95 is written by S. Roesler                 *
17063 ************************************************************************
17064
17065       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17066       SAVE
17067
17068       PARAMETER ( LINP = 10 ,
17069      &            LOUT = 6 ,
17070      &            LDAT = 9 )
17071
17072       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
17073      &           OHALF=0.5D0,ONE=1.0D0)
17074       PARAMETER (FM2MM=1.0D-12,RNUCLE = 1.12D0)
17075       PARAMETER (TWOPI=6.283185307179586454D+00)
17076       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0)
17077
17078       LOGICAL LABSOR,LCAS
17079
17080 * event history
17081
17082       PARAMETER (NMXHKK=200000)
17083
17084       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17085      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17086      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17087
17088 * extended event history
17089       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17090      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17091      &                IHIST(2,NMXHKK)
17092
17093 * final state after inc step
17094       PARAMETER (MAXFSP=10)
17095       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17096
17097 * flags for input different options
17098       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17099       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17100      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17101
17102 * particle properties (BAMJET index convention)
17103       CHARACTER*8  ANAME
17104       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17105      &                IICH(210),IIBAR(210),K1(210),K2(210)
17106
17107 * Glauber formalism: collision properties
17108       COMMON /DTGLCP/ RPROJ,RTARG,BIMPAC,
17109      &                NWTSAM,NWASAM,NWBSAM,NWTACC,NWAACC,NWBACC
17110
17111 * nuclear potential
17112       LOGICAL LFERMI
17113       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
17114      &                EBINDP(2),EBINDN(2),EPOT(2,210),
17115      &                ETACOU(2),ICOUL,LFERMI
17116
17117 * parameter for intranuclear cascade
17118       LOGICAL LPAULI
17119       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
17120
17121 * final state after intranuclear cascade step
17122       COMMON /DTPAUL/ EWOUND(2,300),NWOUND(2),IDXINC(2000),NOINC
17123
17124 * nucleon-nucleon event-generator
17125       CHARACTER*8 CMODEL
17126       LOGICAL LPHOIN
17127       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
17128
17129 * statistics: residual nuclei
17130       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
17131      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
17132      &                NINCST(2,4),NINCEV(2),
17133      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
17134      &                NRESPB(2),NRESCH(2),NRESEV(4),
17135      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
17136      &                NEVAFI(2,2)
17137
17138       DIMENSION PCAS(2,5),PTOCAS(2),COSCAS(2,3),VTXCAS(2,4),VTXCA1(2,4),
17139      &          PCAS1(5),PNUC(5),BGTA(4),
17140      &          BGCAS(2),GACAS(2),BECAS(2),
17141      &          RNUC(2),BIMPC(2),VTXDST(3),IDXSPE(2),IDSPE(2),NWTMP(2)
17142
17143       DATA PDIF /0.545D0/
17144
17145       IREJ = 0
17146
17147 * update counter
17148       IF (NINCEV(1).NE.NEVHKK) THEN
17149          NINCEV(1) = NEVHKK
17150          NINCEV(2) = NINCEV(2)+1
17151       ENDIF
17152
17153 * "BAMJET-index" of this hadron
17154       IDCAS = IDBAM(IDXCAS)
17155       IF (IDT_MCHAD(IDCAS).EQ.-1) RETURN
17156
17157 * skip gammas, electrons, etc..
17158       IF (AAM(IDCAS).LT.TINY2) RETURN
17159
17160 * Lorentz-trsf. into projectile rest system
17161       IF (IP.GT.1) THEN
17162          CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17163      &               PHKK(4,IDXCAS),PCAS(1,1),PCAS(1,2),PCAS(1,3),
17164      &               PCAS(1,4),IDCAS,-2)
17165          PTOCAS(1) = SQRT(PCAS(1,1)**2+PCAS(1,2)**2+PCAS(1,3)**2)
17166          PCAS(1,5) = (PCAS(1,4)-PTOCAS(1))*(PCAS(1,4)+PTOCAS(1))
17167          IF (PCAS(1,5).GT.ZERO) THEN
17168             PCAS(1,5) = SQRT(PCAS(1,5))
17169          ELSE
17170             PCAS(1,5) = AAM(IDCAS)
17171          ENDIF
17172          DO 20 K=1,3
17173             COSCAS(1,K) = PCAS(1,K)/MAX(PTOCAS(1),TINY10)
17174    20    CONTINUE
17175 * Lorentz-parameters
17176 *   particle rest system --> projectile rest system
17177          BGCAS(1) = PTOCAS(1)/MAX(PCAS(1,5),TINY10)
17178          GACAS(1) = PCAS(1,4)/MAX(PCAS(1,5),TINY10)
17179          BECAS(1) = BGCAS(1)/GACAS(1)
17180       ELSE
17181          DO 21 K=1,5
17182             PCAS(1,K) = ZERO
17183             IF (K.LE.3) COSCAS(1,K) = ZERO
17184    21    CONTINUE
17185          PTOCAS(1) = ZERO
17186          BGCAS(1)  = ZERO
17187          GACAS(1)  = ZERO
17188          BECAS(1)  = ZERO
17189       ENDIF
17190 * Lorentz-trsf. into target rest system
17191       IF (IT.GT.1) THEN
17192 * LEPTO: final state particles are already in target rest frame
17193 C        IF (MCGENE.EQ.3) THEN
17194 C           PCAS(2,1) = PHKK(1,IDXCAS)
17195 C           PCAS(2,2) = PHKK(2,IDXCAS)
17196 C           PCAS(2,3) = PHKK(3,IDXCAS)
17197 C           PCAS(2,4) = PHKK(4,IDXCAS)
17198 C        ELSE
17199             CALL DT_LTRANS(PHKK(1,IDXCAS),PHKK(2,IDXCAS),PHKK(3,IDXCAS),
17200      &                  PHKK(4,IDXCAS),PCAS(2,1),PCAS(2,2),PCAS(2,3),
17201      &                  PCAS(2,4),IDCAS,-3)
17202 C        ENDIF
17203          PTOCAS(2) = SQRT(PCAS(2,1)**2+PCAS(2,2)**2+PCAS(2,3)**2)
17204          PCAS(2,5) = (PCAS(2,4)-PTOCAS(2))*(PCAS(2,4)+PTOCAS(2))
17205          IF (PCAS(2,5).GT.ZERO) THEN
17206             PCAS(2,5) = SQRT(PCAS(2,5))
17207          ELSE
17208             PCAS(2,5) = AAM(IDCAS)
17209          ENDIF
17210          DO 22 K=1,3
17211             COSCAS(2,K) = PCAS(2,K)/MAX(PTOCAS(2),TINY10)
17212    22    CONTINUE
17213 * Lorentz-parameters
17214 *   particle rest system --> target rest system
17215          BGCAS(2) = PTOCAS(2)/MAX(PCAS(2,5),TINY10)
17216          GACAS(2) = PCAS(2,4)/MAX(PCAS(2,5),TINY10)
17217          BECAS(2) = BGCAS(2)/GACAS(2)
17218       ELSE
17219          DO 23 K=1,5
17220             PCAS(2,K) = ZERO
17221             IF (K.LE.3) COSCAS(2,K) = ZERO
17222    23    CONTINUE
17223          PTOCAS(2) = ZERO
17224          BGCAS(2)  = ZERO
17225          GACAS(2)  = ZERO
17226          BECAS(2)  = ZERO
17227       ENDIF
17228
17229 * radii of nuclei (mm) modified by the wall-depth of the Woods-Saxon-
17230 * potential (see CONUCL)
17231       RNUC(1)  = (RPROJ+4.605D0*PDIF)*FM2MM
17232       RNUC(2)  = (RTARG+4.605D0*PDIF)*FM2MM
17233 * impact parameter (the projectile moving along z)
17234       BIMPC(1) = ZERO
17235       BIMPC(2) = BIMPAC*FM2MM
17236
17237 * get position of initial hadron in projectile/target rest-syst.
17238       DO 3 K=1,4
17239          VTXCAS(1,K) = WHKK(K,IDXCAS)
17240          VTXCAS(2,K) = VHKK(K,IDXCAS)
17241     3 CONTINUE
17242
17243       ICAS = 1
17244       I2   = 2
17245       IF (NCAS.EQ.-1) THEN
17246          ICAS = 2
17247          I2   = 1
17248       ENDIF
17249
17250       IF (PTOCAS(ICAS).LT.TINY10) THEN
17251          WRITE(LOUT,1000) PTOCAS
17252  1000    FORMAT(1X,'INUCAS:   warning! zero momentum of initial',
17253      &          '  hadron ',/,20X,2E12.4)
17254          GOTO 9999
17255       ENDIF
17256
17257 * reset spectator flags
17258       NSPE = 0
17259       IDXSPE(1) = 0
17260       IDXSPE(2) = 0
17261       IDSPE(1)  = 0
17262       IDSPE(2)  = 0
17263
17264 * formation length (in fm)
17265 C     IF (LCAS) THEN
17266 C        DEL0 = ZERO
17267 C     ELSE
17268          DEL0 = TAUFOR*BGCAS(ICAS)
17269          IF (ITAUVE.EQ.1) THEN
17270             AMT  = PCAS(ICAS,1)**2+PCAS(ICAS,2)**2+PCAS(ICAS,5)**2
17271             DEL0 = DEL0*PCAS(ICAS,5)**2/AMT
17272          ENDIF
17273 C     ENDIF
17274 *   sample from exp(-del/del0)
17275       DEL1   = -DEL0*LOG(MAX(DT_RNDM(DEL0),TINY10))
17276 * save formation time
17277       TAUSA1 = DEL1/BGCAS(ICAS)
17278       REL1   = TAUSA1*BGCAS(I2)
17279
17280       DEL    = DEL1
17281       TAUSAM = DEL/BGCAS(ICAS)
17282       REL    = TAUSAM*BGCAS(I2)
17283
17284 * special treatment for negative particles unable to escape
17285 * nuclear potential (implemented for ap, pi-, K- only)
17286       LABSOR = .FALSE.
17287       IF ((IICH(IDCAS).EQ.-1).AND.(IDCAS.LT.20)) THEN
17288 *   threshold energy = nuclear potential + Coulomb potential
17289 *   (nuclear potential for hadron-nucleus interactions only)
17290          ETHR = AAM(IDCAS)+EPOT(ICAS,IDCAS)+ETACOU(ICAS)
17291          IF (PCAS(ICAS,4).LT.ETHR) THEN
17292             DO 4 K=1,5
17293                PCAS1(K) = PCAS(ICAS,K)
17294     4       CONTINUE
17295 *   "absorb" negative particle in nucleus
17296             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,0,IREJ1)
17297             IF (IREJ1.NE.0) GOTO 9999
17298             IF (NSPE.GE.1) LABSOR = .TRUE.
17299          ENDIF
17300       ENDIF
17301
17302 * if the initial particle has not been absorbed proceed with
17303 * "normal" cascade
17304       IF (.NOT.LABSOR) THEN
17305
17306 *   calculate coordinates of hadron at the end of the formation zone
17307 *   transport-time and -step in the rest system where this step is
17308 *   treated
17309          DSTEP  = DEL*FM2MM
17310          DTIME  = DSTEP/BECAS(ICAS)
17311          RSTEP  = REL*FM2MM
17312          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17313             RTIME = RSTEP/BECAS(I2)
17314          ELSE
17315             RTIME = ZERO
17316          ENDIF
17317 *   save step whithout considering the overlapping region
17318          DSTEP1 = DEL1*FM2MM
17319          DTIME1 = DSTEP1/BECAS(ICAS)
17320          RSTEP1 = REL1*FM2MM
17321          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17322             RTIME1 = RSTEP1/BECAS(I2)
17323          ELSE
17324             RTIME1 = ZERO
17325          ENDIF
17326 *   transport to the end of the formation zone in this system
17327          DO 5 K=1,3
17328             VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+DSTEP1*COSCAS(ICAS,K)
17329             VTXCA1(I2,K)   = VTXCAS(I2,K)  +RSTEP1*COSCAS(I2,K)
17330             VTXCAS(ICAS,K) = VTXCAS(ICAS,K)+DSTEP*COSCAS(ICAS,K)
17331             VTXCAS(I2,K)   = VTXCAS(I2,K)  +RSTEP*COSCAS(I2,K)
17332     5    CONTINUE
17333          VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME1
17334          VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME1
17335          VTXCAS(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17336          VTXCAS(I2,4)   = VTXCAS(I2,4)  +RTIME
17337
17338          IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17339             XCAS   = VTXCAS(ICAS,1)
17340             YCAS   = VTXCAS(ICAS,2)
17341             XNCLTA = BIMPAC*FM2MM
17342             RNCLPR = (RPROJ+RNUCLE)*FM2MM
17343             RNCLTA = (RTARG+RNUCLE)*FM2MM
17344 C           RNCLPR = (RPROJ+1.605D0*PDIF)*FM2MM
17345 C           RNCLTA = (RTARG+1.605D0*PDIF)*FM2MM
17346 C           RNCLPR = (RPROJ)*FM2MM
17347 C           RNCLTA = (RTARG)*FM2MM
17348             RCASPR = SQRT( XCAS**2        +YCAS**2)
17349             RCASTA = SQRT((XCAS-XNCLTA)**2+YCAS**2)
17350             IF ((RCASPR.LT.RNCLPR).AND.(RCASTA.LT.RNCLTA)) THEN
17351                IF (IDCH(IDXCAS).EQ.0) NOBAM(IDXCAS) = 3
17352             ENDIF
17353          ENDIF
17354
17355 *   check if particle is already outside of the corresp. nucleus
17356          RDIST = SQRT((VTXCAS(ICAS,1)-BIMPC(ICAS))**2+
17357      &                VTXCAS(ICAS,2)**2+VTXCAS(ICAS,3)**2)
17358          IF (RDIST.GE.RNUC(ICAS)) THEN
17359 *   here: IDCH is the generation of the final state part. starting
17360 *   with zero for hadronization products
17361 *   flag particles of generation 0 being outside the nuclei after
17362 *   formation time (to be used for excitation energy calculation)
17363             IF ((IDCH(IDXCAS).EQ.0).AND.(NOBAM(IDXCAS).LT.3))
17364      &         NOBAM(IDXCAS) = NOBAM(IDXCAS)+ICAS
17365             GOTO 9997
17366          ENDIF
17367          DIST   = DLARGE
17368          DISTP  = DLARGE
17369          DISTN  = DLARGE
17370          IDXP   = 0
17371          IDXN   = 0
17372
17373 *   already here: skip particles being outside HADRIN "energy-window"
17374 *   to avoid wasting of time
17375          NINCHR(ICAS,1) = NINCHR(ICAS,1)+1
17376          IF ((PTOCAS(ICAS).LE.PLOWH).OR.(PTOCAS(ICAS).GE.PHIH)) THEN
17377             NINCHR(ICAS,2) = NINCHR(ICAS,2)+1
17378 C           WRITE(LOUT,1002) IDXCAS,IDCAS,ICAS,PTOCAS(ICAS),NEVHKK
17379 C1002       FORMAT(1X,'INUCAS:   warning! momentum of particle with ',
17380 C    &             'index ',I5,' (id: ',I3,') ',I3,/,11X,'p_tot = ',
17381 C    &             E12.4,', above or below HADRIN-thresholds',I6)
17382             NSPE = 0
17383             GOTO 9997
17384          ENDIF
17385
17386          DO 7 IDXHKK=1,NOINC
17387             I = IDXINC(IDXHKK)
17388 *   scan DTEVT1 for unwounded or excited nucleons
17389             IF ((ISTHKK(I).EQ.12+ICAS).OR.(ISTHKK(I).EQ.14+ICAS)) THEN
17390                DO 8 K=1,3
17391                   IF (ICAS.EQ.1) THEN
17392                      VTXDST(K) = WHKK(K,I)-VTXCAS(1,K)
17393                   ELSEIF (ICAS.EQ.2) THEN
17394                      VTXDST(K) = VHKK(K,I)-VTXCAS(2,K)
17395                   ENDIF
17396     8          CONTINUE
17397                POSNUC = VTXDST(1)*COSCAS(ICAS,1)+
17398      &                  VTXDST(2)*COSCAS(ICAS,2)+
17399      &                  VTXDST(3)*COSCAS(ICAS,3)
17400 *   check if nucleon is situated in forward direction
17401                IF (POSNUC.GT.ZERO) THEN
17402 *   distance between hadron and this nucleon
17403                   DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17404      &                          VTXDST(3)**2)
17405 *   impact parameter
17406                   BIMNU2 = DISTNU**2-POSNUC**2
17407                   IF (BIMNU2.LT.ZERO) THEN
17408                      WRITE(LOUT,1001) DISTNU,POSNUC,BIMNU2
17409  1001                FORMAT(1X,'INUCAS:   warning! inconsistent impact',
17410      &                      '  parameter ',/,20X,3E12.4)
17411                      GOTO 7
17412                   ENDIF
17413                   BIMNU  = SQRT(BIMNU2)
17414 *   maximum impact parameter to have interaction
17415                   IDNUC  = IDT_ICIHAD(IDHKK(I))
17416                   IDNUC1 = IDT_MCHAD(IDNUC)
17417                   IDCAS1 = IDT_MCHAD(IDCAS)
17418                   DO 19 K=1,5
17419                      PCAS1(K) = PCAS(ICAS,K)
17420                      PNUC(K)  = PHKK(K,I)
17421    19             CONTINUE
17422 * Lorentz-parameter for trafo into rest-system of target
17423                   DO 18 K=1,4
17424                      BGTA(K) = PNUC(K)/MAX(PNUC(5),TINY10)
17425    18             CONTINUE
17426 * transformation of projectile into rest-system of target
17427                   CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),
17428      &                        PCAS1(1),PCAS1(2),PCAS1(3),PCAS1(4),
17429      &                        PPTOT,PX,PY,PZ,PE)
17430 **
17431 C                 CALL DT_SIHNIN(IDCAS1,IDNUC1,PPTOT,SIGIN)
17432 C                 CALL DT_SIHNEL(IDCAS1,IDNUC1,PPTOT,SIGEL)
17433                   DUMZER = ZERO
17434                   CALL DT_XSHN(IDCAS1,IDNUC1,PPTOT,DUMZER,SIGTOT,SIGEL)
17435                   CALL DT_SIHNAB(IDCAS1,IDNUC1,PPTOT,SIGAB)
17436                   IF (((IDCAS1.EQ.13).OR.(IDCAS1.EQ.14)).AND.
17437      &                (PPTOT.LT.0.15D0)) SIGEL = SIGEL/2.0D0
17438                   SIGIN = SIGTOT-SIGEL-SIGAB
17439 C                 SIGTOT = SIGIN+SIGEL+SIGAB
17440 **
17441                   BIMMAX = SQRT(SIGTOT/(5.0D0*TWOPI))*FM2MM
17442 *   check if interaction is possible
17443                   IF (BIMNU.LE.BIMMAX) THEN
17444 *   get nucleon with smallest distance and kind of interaction
17445 *   (elastic/inelastic)
17446                      IF (DISTNU.LT.DIST) THEN
17447                         DIST      = DISTNU
17448                         BINT      = BIMNU
17449                         IF (IDNUC.NE.IDSPE(1)) THEN
17450                            IDSPE(2)  = IDSPE(1)
17451                            IDXSPE(2) = IDXSPE(1)
17452                            IDSPE(1)  = IDNUC
17453                         ENDIF
17454                         IDXSPE(1) = I
17455                         NSPE      = 1
17456 **sr
17457                         SELA = SIGEL
17458                         SABS = SIGAB
17459                         STOT = SIGTOT
17460 C                       IF ((IDCAS.EQ.2).OR.(IDCAS.EQ.9)) THEN
17461 C                          SELA = SIGEL
17462 C                          STOT = SIGIN+SIGEL
17463 C                       ELSE
17464 C                          SELA = SIGEL+0.75D0*SIGIN
17465 C                          STOT = 0.25D0*SIGIN+SELA
17466 C                       ENDIF
17467 **
17468                      ENDIF
17469                   ENDIf
17470                ENDIF
17471                DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17472      &                       VTXDST(3)**2)
17473                IDNUC  = IDT_ICIHAD(IDHKK(I))
17474                IF (IDNUC.EQ.1) THEN
17475                   IF (DISTNU.LT.DISTP) THEN
17476                      DISTP = DISTNU
17477                      IDXP  = I
17478                      POSP  = POSNUC
17479                   ENDIF
17480                ELSEIF (IDNUC.EQ.8) THEN
17481                   IF (DISTNU.LT.DISTN) THEN
17482                      DISTN = DISTNU
17483                      IDXN  = I
17484                      POSN  = POSNUC
17485                   ENDIF
17486                ENDIF
17487             ENDIF
17488     7    CONTINUE
17489
17490 * there is no nucleon for a secondary interaction
17491          IF (NSPE.EQ.0) GOTO 9997
17492
17493 C        IF ((IDCAS.EQ.13).AND.((PCAS(ICAS,4)-PCAS(ICAS,5)).LT.0.1D0))
17494 C    &      WRITE(LOUT,*) STOT,SELA,SABS,IDXSPE
17495          IF (IDXSPE(2).EQ.0) THEN
17496             IF ((IDSPE(1).EQ.1).AND.(IDXN.GT.0)) THEN
17497 C              DO 80 K=1,3
17498 C                 IF (ICAS.EQ.1) THEN
17499 C                    VTXDST(K) = WHKK(K,IDXN)-WHKK(K,IDXSPE(1))
17500 C                 ELSEIF (ICAS.EQ.2) THEN
17501 C                    VTXDST(K) = VHKK(K,IDXN)-VHKK(K,IDXSPE(1))
17502 C                 ENDIF
17503 C  80          CONTINUE
17504 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17505 C    &                       VTXDST(3)**2)
17506 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSN.GT.ZERO)) THEN
17507                   IDXSPE(2) = IDXN
17508                   IDSPE(2)  = 8
17509 C              ELSE
17510 C                 STOT = STOT-SABS
17511 C                 SABS = ZERO
17512 C              ENDIF
17513             ELSEIF ((IDSPE(1).EQ.8).AND.(IDXP.GT.0)) THEN
17514 C              DO 81 K=1,3
17515 C                 IF (ICAS.EQ.1) THEN
17516 C                    VTXDST(K) = WHKK(K,IDXP)-WHKK(K,IDXSPE(1))
17517 C                 ELSEIF (ICAS.EQ.2) THEN
17518 C                    VTXDST(K) = VHKK(K,IDXP)-VHKK(K,IDXSPE(1))
17519 C                 ENDIF
17520 C  81          CONTINUE
17521 C              DISTNU = SQRT(VTXDST(1)**2+VTXDST(2)**2+
17522 C    &                       VTXDST(3)**2)
17523 C              IF ((DISTNU.LT.15.0D0*FM2MM).OR.(POSP.GT.ZERO)) THEN
17524                   IDXSPE(2) = IDXP
17525                   IDSPE(2)  = 1
17526 C              ELSE
17527 C                 STOT = STOT-SABS
17528 C                 SABS = ZERO
17529 C              ENDIF
17530             ELSE
17531                STOT = STOT-SABS
17532                SABS = ZERO
17533             ENDIF
17534          ENDIF
17535          RR = DT_RNDM(DIST)
17536          IF (RR.LT.SELA/STOT) THEN
17537             IPROC = 2
17538          ELSEIF ((RR.GE.SELA/STOT).AND.(RR.LT.(SELA+SABS)/STOT)) THEN
17539             IPROC = 3
17540          ELSE
17541             IPROC = 1
17542          ENDIF
17543
17544          DO 9 K=1,5
17545             PCAS1(K) = PCAS(ICAS,K)
17546             PNUC(K)  = PHKK(K,IDXSPE(1))
17547     9    CONTINUE
17548          IF (IPROC.EQ.3) THEN
17549 * 2-nucleon absorption of pion
17550             NSPE = 2
17551             CALL DT_ABSORP(IDCAS,PCAS1,NCAS,NSPE,IDSPE,IDXSPE,1,IREJ1)
17552             IF (IREJ1.NE.0) GOTO 9999
17553             IF (NSPE.GE.1) LABSOR = .TRUE.
17554          ELSE
17555 * sample secondary interaction
17556             IDNUC = IDBAM(IDXSPE(1))
17557             CALL DT_HADRIN(IDCAS,PCAS1,IDNUC,PNUC,IPROC,IREJ1)
17558             IF (IREJ1.EQ.1) GOTO 9999
17559             IF (IREJ1.GT.1) GOTO 9998
17560          ENDIF
17561       ENDIF
17562
17563 * update arrays to include Pauli-principle
17564       DO 10 I=1,NSPE
17565          IF (NWOUND(ICAS).LE.299) THEN
17566             NWOUND(ICAS) = NWOUND(ICAS)+1
17567             EWOUND(ICAS,NWOUND(ICAS)) = PHKK(4,IDXSPE(I))
17568          ENDIF
17569    10 CONTINUE
17570
17571 * dump initial hadron for energy-momentum conservation check
17572       IF (LEMCCK)
17573      &   CALL DT_EVTEMC(PCAS(ICAS,1),PCAS(ICAS,2),PCAS(ICAS,3),
17574      &               PCAS(ICAS,4),1,IDUM,IDUM)
17575
17576 * dump final state particles into DTEVT1
17577
17578 *   check if Pauli-principle is fulfilled
17579       NPAULI = 0
17580       NWTMP(1) = NWOUND(1)
17581       NWTMP(2) = NWOUND(2)
17582       DO 111 I=1,NFSP
17583          NPAULI = 0
17584          J1 = 2
17585          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17586      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
17587          DO 117 J=1,J1
17588             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 117
17589             IF (J.EQ.1) THEN
17590                IDX = ICAS
17591                PE  = PFSP(4,I)
17592             ELSE
17593                IDX  = I2
17594                MODE = 1
17595                IF (IDX.EQ.1) MODE = -1
17596                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,MODE)
17597             ENDIF
17598 * first check if cascade step is forbidden due to Pauli-principle
17599 * (in case of absorpion this step is forced)
17600             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17601      &          (IDFSP(I).EQ.8))) THEN
17602 *   get nuclear potential barrier
17603                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17604                IF (IDFSP(I).EQ.1) THEN
17605                   POTLOW = POT-EBINDP(IDX)
17606                ELSE
17607                   POTLOW = POT-EBINDN(IDX)
17608                ENDIF
17609 *   final state particle not able to escape nucleus
17610                IF (PE.LE.POTLOW) THEN
17611 *     check if there are wounded nucleons
17612                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17613      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
17614                      NPAULI      = NPAULI+1
17615                      NWOUND(IDX) = NWOUND(IDX)-1
17616                   ELSE
17617 *     interaction prohibited by Pauli-principle
17618                      NWOUND(1) = NWTMP(1)
17619                      NWOUND(2) = NWTMP(2)
17620                      GOTO 9997
17621                   ENDIF
17622                ENDIF
17623             ENDIF
17624   117    CONTINUE
17625   111 CONTINUE
17626
17627       NPAULI = 0
17628       NWOUND(1) = NWTMP(1)
17629       NWOUND(2) = NWTMP(2)
17630
17631       DO 11 I=1,NFSP
17632
17633          IST = ISTHKK(IDXCAS)
17634
17635          NPAULI = 0
17636          J1 = 2
17637          IF (((NCAS.EQ. 1).AND.(IT.LE.1)).OR.
17638      &       ((NCAS.EQ.-1).AND.(IP.LE.1)))    J1 = 1
17639          DO 17 J=1,J1
17640             IF ((NPAULI.NE.0).AND.(J.EQ.2)) GOTO 17
17641             IDX = ICAS
17642             PE  = PFSP(4,I)
17643             IF (J.EQ.2) THEN
17644                IDX = I2
17645                CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PZ,PE,NCAS)
17646             ENDIF
17647 * first check if cascade step is forbidden due to Pauli-principle
17648 * (in case of absorpion this step is forced)
17649             IF ((.NOT.LABSOR).AND.LPAULI.AND.((IDFSP(I).EQ.1).OR.
17650      &          (IDFSP(I).EQ.8))) THEN
17651 *   get nuclear potential barrier
17652                POT = EPOT(IDX,IDFSP(I))+AAM(IDFSP(I))
17653                IF (IDFSP(I).EQ.1) THEN
17654                   POTLOW = POT-EBINDP(IDX)
17655                ELSE
17656                   POTLOW = POT-EBINDN(IDX)
17657                ENDIF
17658 *   final state particle not able to escape nucleus
17659                IF (PE.LE.POTLOW) THEN
17660 *     check if there are wounded nucleons
17661                   IF ((NWOUND(IDX).GE.1).AND.(PE.GE.
17662      &                 EWOUND(IDX,NWOUND(IDX)))) THEN
17663                      NWOUND(IDX) = NWOUND(IDX)-1
17664                      NPAULI = NPAULI+1
17665                      IST    = 14+IDX
17666                   ELSE
17667 *     interaction prohibited by Pauli-principle
17668                      NWOUND(1) = NWTMP(1)
17669                      NWOUND(2) = NWTMP(2)
17670                      GOTO 9997
17671                   ENDIF
17672 **sr
17673 c               ELSEIF (PE.LE.POT) THEN
17674 cC              ELSEIF ((PE.LE.POT).AND.(NWOUND(IDX).GE.1)) THEN
17675 cC                 NWOUND(IDX) = NWOUND(IDX)-1
17676 c**
17677 c                  NPAULI = NPAULI+1
17678 c                  IST    = 14+IDX
17679                ENDIF
17680             ENDIF
17681    17    CONTINUE
17682
17683 * dump final state particles for energy-momentum conservation check
17684          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),-PFSP(3,I),
17685      &                           -PFSP(4,I),2,IDUM,IDUM)
17686
17687          PX = PFSP(1,I)
17688          PY = PFSP(2,I)
17689          PZ = PFSP(3,I)
17690          PE = PFSP(4,I)
17691          IF (ABS(IST).EQ.1) THEN
17692 * transform particles back into n-n cms
17693 * LEPTO: leave final state particles in target rest frame
17694 C           IF (MCGENE.EQ.3) THEN
17695 C              PFSP(1,I) = PX
17696 C              PFSP(2,I) = PY
17697 C              PFSP(3,I) = PZ
17698 C              PFSP(4,I) = PE
17699 C           ELSE
17700                IMODE = ICAS+1
17701                CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17702      &                     PFSP(4,I),IDFSP(I),IMODE)
17703 C           ENDIF
17704          ELSEIF ((ICAS.EQ.2).AND.(IST.EQ.15)) THEN
17705 * target cascade but fsp got stuck in proj. --> transform it into
17706 * proj. rest system
17707             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17708      &                  PFSP(4,I),IDFSP(I),-1)
17709          ELSEIF ((ICAS.EQ.1).AND.(IST.EQ.16)) THEN
17710 * proj. cascade but fsp got stuck in target --> transform it into
17711 * target rest system
17712             CALL DT_LTRANS(PX,PY,PZ,PE,PFSP(1,I),PFSP(2,I),PFSP(3,I),
17713      &                  PFSP(4,I),IDFSP(I),1)
17714          ENDIF
17715
17716 * dump final state particles into DTEVT1
17717          IGEN = IDCH(IDXCAS)+1
17718          ID   = IDT_IPDGHA(IDFSP(I))
17719          IXR  = 0
17720          IF (LABSOR) IXR = 99
17721          CALL DT_EVTPUT(IST,ID,IDXCAS,IDXSPE(1),PFSP(1,I),
17722      &               PFSP(2,I),PFSP(3,I),PFSP(4,I),0,IXR,IGEN)
17723
17724 * update the counter for particles which got stuck inside the nucleus
17725          IF ((IST.EQ.15).OR.(IST.EQ.16)) THEN
17726             NOINC = NOINC+1
17727             IDXINC(NOINC) = NHKK
17728          ENDIF
17729          IF (LABSOR) THEN
17730 *   in case of absorption the spatial treatment is an approximate
17731 *   solution anyway (the positions of the nucleons which "absorb" the
17732 *   cascade particle are not taken into consideration) therefore the
17733 *   particles are produced at the position of the cascade particle
17734             DO 12 K=1,4
17735                WHKK(K,NHKK) = WHKK(K,IDXCAS)
17736                VHKK(K,NHKK) = VHKK(K,IDXCAS)
17737    12       CONTINUE
17738          ELSE
17739 *   DDISTL - distance the cascade particle moves to the intera. point
17740 *   (the position where impact-parameter = distance to the interacting
17741 *   nucleon), DIST - distance to the interacting nucleon at the time of
17742 *   formation of the cascade particle, BINT - impact-parameter of this
17743 *   cascade-interaction
17744             DDISTL = SQRT(DIST**2-BINT**2)
17745             DTIME  = DDISTL/BECAS(ICAS)
17746             DTIMEL = DDISTL/BGCAS(ICAS)
17747             RDISTL = DTIMEL*BGCAS(I2)
17748             IF ((IP.GT.1).AND.(IT.GT.1)) THEN
17749                RTIME = RDISTL/BECAS(I2)
17750             ELSE
17751                RTIME = ZERO
17752             ENDIF
17753 *   RDISTL, RTIME are this step and time in the rest system of the other
17754 *   nucleus
17755             DO 13 K=1,3
17756                VTXCA1(ICAS,K) = VTXCAS(ICAS,K)+COSCAS(ICAS,K)*DDISTL
17757                VTXCA1(I2,K)   = VTXCAS(I2,K)  +COSCAS(I2,K)  *RDISTL
17758    13       CONTINUE
17759             VTXCA1(ICAS,4) = VTXCAS(ICAS,4)+DTIME
17760             VTXCA1(I2,4)   = VTXCAS(I2,4)  +RTIME
17761 *   position of particle production is half the impact-parameter to
17762 *   the interacting nucleon
17763             DO 14 K=1,3
17764                WHKK(K,NHKK) = OHALF*(VTXCA1(1,K)+WHKK(K,IDXSPE(1)))
17765                VHKK(K,NHKK) = OHALF*(VTXCA1(2,K)+VHKK(K,IDXSPE(1)))
17766    14       CONTINUE
17767 *   time of production of secondary = time of interaction
17768             WHKK(4,NHKK) = VTXCA1(1,4)
17769             VHKK(4,NHKK) = VTXCA1(2,4)
17770          ENDIF
17771
17772    11 CONTINUE
17773
17774 * modify status and position of cascade particle (the latter for
17775 * statistics reasons only)
17776       ISTHKK(IDXCAS) = 2
17777       IF (LABSOR) ISTHKK(IDXCAS) = 19
17778       IF (.NOT.LABSOR) THEN
17779          DO 15 K=1,4
17780             WHKK(K,IDXCAS) = VTXCA1(1,K)
17781             VHKK(K,IDXCAS) = VTXCA1(2,K)
17782    15    CONTINUE
17783       ENDIF
17784
17785       DO 16 I=1,NSPE
17786          IS = IDXSPE(I)
17787 * dump interacting nucleons for energy-momentum conservation check
17788          IF (LEMCCK)
17789      &      CALL DT_EVTEMC(PHKK(1,IS),PHKK(2,IS),PHKK(3,IS),PHKK(4,IS),
17790      &                                                  2,IDUM,IDUM)
17791 * modify entry for interacting nucleons
17792          IF (ISTHKK(IS).EQ.12+ICAS) ISTHKK(IS)=16+ICAS
17793          IF (ISTHKK(IS).EQ.14+ICAS) ISTHKK(IS)=2
17794          IF (I.GE.2) THEN
17795             JDAHKK(1,IS) = JDAHKK(1,IDXSPE(1))
17796             JDAHKK(2,IS) = JDAHKK(2,IDXSPE(1))
17797          ENDIF
17798    16 CONTINUE
17799
17800 * check energy-momentum conservation
17801       IF (LEMCCK) THEN
17802          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,500,IREJ1)
17803          IF (IREJ1.NE.0) GOTO 9999
17804       ENDIF
17805
17806 * update counter
17807       IF (LABSOR) THEN
17808          NINCCO(ICAS,1) = NINCCO(ICAS,1)+1
17809       ELSE
17810          IF (IPROC.EQ.1) NINCCO(ICAS,2) = NINCCO(ICAS,2)+1
17811          IF (IPROC.EQ.2) NINCCO(ICAS,3) = NINCCO(ICAS,3)+1
17812       ENDIF
17813
17814       RETURN
17815
17816  9997 CONTINUE
17817  9998 CONTINUE
17818 * transport-step but no cascade step due to configuration (i.e. there
17819 * is no nucleon for interaction etc.)
17820       IF (LCAS) THEN
17821          DO 100 K=1,4
17822 C           WHKK(K,IDXCAS) = VTXCAS(1,K)
17823 C           VHKK(K,IDXCAS) = VTXCAS(2,K)
17824             WHKK(K,IDXCAS) = VTXCA1(1,K)
17825             VHKK(K,IDXCAS) = VTXCA1(2,K)
17826   100    CONTINUE
17827       ENDIF
17828
17829 C9998 CONTINUE
17830 * no cascade-step because of configuration
17831 * (i.e. hadron outside nucleus etc.)
17832       LCAS = .TRUE.
17833       RETURN
17834
17835  9999 CONTINUE
17836 * rejection
17837       IREJ = 1
17838       RETURN
17839       END
17840
17841 *$ CREATE DT_ABSORP.FOR
17842 *COPY DT_ABSORP
17843 *
17844 *===absorp=============================================================*
17845 *
17846       SUBROUTINE DT_ABSORP(IDCAS,PCAS,NCAS,NSPE,IDSPE,IDXSPE,MODE,IREJ)
17847
17848 ************************************************************************
17849 * Two-nucleon absorption of antiprotons, pi-, and K-.                  *
17850 * Antiproton absorption is handled by HADRIN.                          *
17851 * The following channels for meson-absorption are considered:          *
17852 *          pi- + p + p ---> n + p                                      *
17853 *          pi- + p + n ---> n + n                                      *
17854 *          K-  + p + p ---> sigma+ + n / Lam + p / sigma0 + p          *
17855 *          K-  + p + n ---> sigma- + n / Lam + n / sigma0 + n          *
17856 *          K-  + p + p ---> sigma- + n                                 *
17857 *      IDCAS, PCAS   identity, momentum of particle to be absorbed     *
17858 *      NCAS =  1     intranuclear cascade in projectile                *
17859 *           = -1     intranuclear cascade in target                    *
17860 *      NSPE          number of spectator nucleons involved             *
17861 *      IDXSPE(2)     DTEVT1-indices of spectator nucleons involved     *
17862 * Revised version of the original STOPIK written by HJM and J. Ranft.  *
17863 * This version dated 24.02.95 is written by S. Roesler                 *
17864 ************************************************************************
17865
17866       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
17867       SAVE
17868
17869       PARAMETER ( LINP = 10 ,
17870      &            LOUT = 6 ,
17871      &            LDAT = 9 )
17872
17873       PARAMETER (TINY10=1.0D-10,TINY5=1.0D-5,ONE=1.0D0,
17874      &           ONETHI=0.3333D0,TWOTHI=0.6666D0)
17875
17876 * event history
17877
17878       PARAMETER (NMXHKK=200000)
17879
17880       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
17881      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
17882      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
17883
17884 * extended event history
17885       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
17886      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
17887      &                IHIST(2,NMXHKK)
17888
17889 * flags for input different options
17890       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
17891       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
17892      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
17893
17894 * final state after inc step
17895       PARAMETER (MAXFSP=10)
17896       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
17897
17898 * particle properties (BAMJET index convention)
17899       CHARACTER*8  ANAME
17900       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
17901      &                IICH(210),IIBAR(210),K1(210),K2(210)
17902
17903       DIMENSION PCAS(5),IDXSPE(2),IDSPE(2),PSPE(2,5),PSPE1(5),
17904      &          PTOT3P(4),BG3P(4),
17905      &          ECMF(2),PCMF(2),CODF(2),COFF(2),SIFF(2)
17906
17907       IREJ = 0
17908       NFSP = 0
17909
17910 * skip particles others than ap, pi-, K- for mode=0
17911       IF ((MODE.EQ.0).AND.
17912      &    (IDCAS.NE.2).AND.(IDCAS.NE.14).AND.(IDCAS.NE.16)) RETURN
17913 * skip particles others than pions for mode=1
17914 * (2-nucleon absorption in intranuclear cascade)
17915       IF ((MODE.EQ.1).AND.
17916      &    (IDCAS.NE.13).AND.(IDCAS.NE.14).AND.(IDCAS.NE.23)) RETURN
17917
17918       NUCAS = NCAS
17919       IF (NUCAS.EQ.-1) NUCAS = 2
17920
17921       IF (MODE.EQ.0) THEN
17922 * scan spectator nucleons for nucleons being able to "absorb"
17923          NSPE      = 0
17924          IDXSPE(1) = 0
17925          IDXSPE(2) = 0
17926          DO 1 I=1,NHKK
17927             IF ((ISTHKK(I).EQ.12+NUCAS).OR.(ISTHKK(I).EQ.14+NUCAS)) THEN
17928                NSPE         = NSPE+1
17929                IDXSPE(NSPE) = I
17930                IDSPE(NSPE)  = IDBAM(I)
17931                IF ((NSPE.EQ.1).AND.(IDCAS.EQ.2)) GOTO 2
17932                IF (NSPE.EQ.2) THEN
17933                   IF ((IDCAS.EQ.14).AND.(IDSPE(1).EQ.8).AND.
17934      &                                  (IDSPE(2).EQ.8)) THEN
17935 *    there is no pi-+n+n channel
17936                      NSPE = 1
17937                      GOTO 1
17938                   ELSE
17939                      GOTO 2
17940                   ENDIF
17941                ENDIF
17942             ENDIF
17943     1    CONTINUE
17944
17945     2    CONTINUE
17946       ENDIF
17947 * transform excited projectile nucleons (status=15) into proj. rest s.
17948       DO 3 I=1,NSPE
17949          DO 4 K=1,5
17950             PSPE(I,K) = PHKK(K,IDXSPE(I))
17951     4    CONTINUE
17952     3 CONTINUE
17953
17954 * antiproton absorption
17955       IF ((IDCAS.EQ.2).AND.(NSPE.GE.1)) THEN
17956          DO 5 K=1,5
17957             PSPE1(K) = PSPE(1,K)
17958     5    CONTINUE
17959          CALL DT_HADRIN(IDCAS,PCAS,IDSPE(1),PSPE1,1,IREJ1)
17960          IF (IREJ1.NE.0) GOTO 9999
17961
17962 * meson absorption
17963       ELSEIF (((IDCAS.EQ.13).OR.(IDCAS.EQ.14).OR.(IDCAS.EQ.23)
17964      &                      .OR.(IDCAS.EQ.16)).AND.(NSPE.GE.2)) THEN
17965          IF (IDCAS.EQ.14) THEN
17966 *   pi- absorption
17967             IDFSP(1) = 8
17968             IDFSP(2) = 8
17969             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) IDFSP(2) = 1
17970          ELSEIF (IDCAS.EQ.13) THEN
17971 *   pi+ absorption
17972             IDFSP(1) = 1
17973             IDFSP(2) = 1
17974             IF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) IDFSP(2) = 8
17975          ELSEIF (IDCAS.EQ.23) THEN
17976 *   pi0 absorption
17977             IDFSP(1) = IDSPE(1)
17978             IDFSP(2) = IDSPE(2)
17979          ELSEIF (IDCAS.EQ.16) THEN
17980 *   K- absorption
17981             R = DT_RNDM(PCAS)
17982             IF ((IDSPE(1).EQ.1).AND.(IDSPE(2).EQ.1)) THEN
17983                IF (R.LT.ONETHI) THEN
17984                   IDFSP(1) = 21
17985                   IDFSP(2) = 8
17986                ELSEIF (R.LT.TWOTHI) THEN
17987                   IDFSP(1) = 17
17988                   IDFSP(2) = 1
17989                ELSE
17990                   IDFSP(1) = 22
17991                   IDFSP(2) = 1
17992                ENDIF
17993             ELSEIF ((IDSPE(1).EQ.8).AND.(IDSPE(2).EQ.8)) THEN
17994                IDFSP(1) = 20
17995                IDFSP(2) = 8
17996             ELSE
17997                IF (R.LT.ONETHI) THEN
17998                   IDFSP(1) = 20
17999                   IDFSP(2) = 1
18000                ELSEIF (R.LT.TWOTHI) THEN
18001                   IDFSP(1) = 17
18002                   IDFSP(2) = 8
18003                ELSE
18004                   IDFSP(1) = 22
18005                   IDFSP(2) = 8
18006                ENDIF
18007             ENDIF
18008          ENDIF
18009 *   dump initial particles for energy-momentum cons. check
18010          IF (LEMCCK) THEN
18011             CALL DT_EVTEMC(PCAS(1),PCAS(2),PCAS(3),PCAS(4),1,IDUM,IDUM)
18012             CALL DT_EVTEMC(PSPE(1,1),PSPE(1,2),PSPE(1,3),PSPE(1,4),2,
18013      &                                                    IDUM,IDUM)
18014             CALL DT_EVTEMC(PSPE(2,1),PSPE(2,2),PSPE(2,3),PSPE(2,4),2,
18015      &                                                    IDUM,IDUM)
18016          ENDIF
18017 *   get Lorentz-parameter of 3 particle initial state
18018          DO 6 K=1,4
18019             PTOT3P(K) = PCAS(K)+PSPE(1,K)+PSPE(2,K)
18020     6    CONTINUE
18021          P3P  = SQRT(PTOT3P(1)**2+PTOT3P(2)**2+PTOT3P(3)**2)
18022          AM3P = SQRT( (PTOT3P(4)-P3P)*(PTOT3P(4)+P3P) )
18023          DO 7 K=1,4
18024             BG3P(K) = PTOT3P(K)/MAX(AM3P,TINY10)
18025     7    CONTINUE
18026 *   2-particle decay of the 3-particle compound system
18027          CALL DT_DTWOPD(AM3P,ECMF(1),ECMF(2),PCMF(1),PCMF(2),
18028      &               CODF(1),COFF(1),SIFF(1),CODF(2),COFF(2),SIFF(2),
18029      &               AAM(IDFSP(1)),AAM(IDFSP(2)))
18030          DO 8 I=1,2
18031             SDF = SQRT((ONE-CODF(I))*(ONE+CODF(I)))
18032             PX  = PCMF(I)*COFF(I)*SDF
18033             PY  = PCMF(I)*SIFF(I)*SDF
18034             PZ  = PCMF(I)*CODF(I)
18035             CALL DT_DALTRA(BG3P(4),BG3P(1),BG3P(2),BG3P(3),PX,PY,PZ,
18036      &                  ECMF(I),PTOFSP,PFSP(1,I),PFSP(2,I),PFSP(3,I),
18037      &                  PFSP(4,I))
18038             PFSP(5,I) = SQRT( (PFSP(4,I)-PTOFSP)*(PFSP(4,I)+PTOFSP) )
18039 *   check consistency of kinematics
18040             IF (ABS(AAM(IDFSP(I))-PFSP(5,I)).GT.TINY5) THEN
18041                WRITE(LOUT,1001) IDFSP(I),AAM(IDFSP(I)),PFSP(5,I)
18042  1001          FORMAT(1X,'ABSORP:   warning! inconsistent',
18043      &                ' tree-particle kinematics',/,20X,'id: ',I3,
18044      &                ' AAM = ',E10.4,' MFSP = ',E10.4)
18045             ENDIF
18046 *   dump final state particles for energy-momentum cons. check
18047             IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18048      &                              -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18049     8    CONTINUE
18050          NFSP = 2
18051          IF (LEMCCK) THEN
18052             CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,100,IREJ1)
18053             IF (IREJ1.NE.0) THEN
18054                WRITE(LOUT,*)'ABSORB: EMC ',AAM(IDFSP(1)),AAM(IDFSP(2)),
18055      &                      AM3P
18056                GOTO 9999
18057             ENDIF
18058          ENDIF
18059       ELSE
18060          IF (IOULEV(3).GT.0) WRITE(LOUT,1000) IDCAS,NSPE
18061  1000    FORMAT(1X,'ABSORP:   warning! absorption for particle ',I3,
18062      &          ' impossible',/,20X,'too few spectators (',I2,')')
18063          NSPE = 0
18064       ENDIF
18065
18066       RETURN
18067
18068  9999 CONTINUE
18069       IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in ABSORP'
18070       IREJ = 1
18071       RETURN
18072       END
18073
18074 *$ CREATE DT_HADRIN.FOR
18075 *COPY DT_HADRIN
18076 *
18077 *===hadrin=============================================================*
18078 *
18079       SUBROUTINE DT_HADRIN(IDPR,PPR,IDTA,PTA,MODE,IREJ)
18080
18081 ************************************************************************
18082 * Interface to the HADRIN-routines for inelastic and elastic           *
18083 * scattering.                                                          *
18084 *      IDPR,PPR(5)   identity, momentum of projectile                  *
18085 *      IDTA,PTA(5)   identity, momentum of target                      *
18086 *      MODE  = 1     inelastic interaction                             *
18087 *            = 2     elastic   interaction                             *
18088 * Revised version of the original FHAD.                                *
18089 * This version dated 27.10.95 is written by S. Roesler                 *
18090 ************************************************************************
18091
18092       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18093       SAVE
18094
18095       PARAMETER ( LINP = 10 ,
18096      &            LOUT = 6 ,
18097      &            LDAT = 9 )
18098
18099       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY5=1.0D-5,TINY3=1.0D-3,
18100      &           TINY2=1.0D-2,TINY1=1.0D-1,ONE=1.0D0)
18101
18102       LOGICAL LCORR,LMSSG
18103
18104 * flags for input different options
18105       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18106       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18107      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18108
18109 * final state after inc step
18110       PARAMETER (MAXFSP=10)
18111       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18112
18113 * particle properties (BAMJET index convention)
18114       CHARACTER*8  ANAME
18115       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18116      &                IICH(210),IIBAR(210),K1(210),K2(210)
18117 * output-common for DHADRI/ELHAIN
18118
18119 * final state from HADRIN interaction
18120       PARAMETER (MAXFIN=10)
18121       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
18122      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
18123
18124       DIMENSION PPR(5),PPR1(5),PTA(5),BGTA(4),
18125      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4),IMCORR(2)
18126
18127       DATA LMSSG /.TRUE./
18128
18129       IREJ  = 0
18130       NFSP  = 0
18131       KCORR = 0
18132       IMCORR(1) = 0
18133       IMCORR(2) = 0
18134       LCORR = .FALSE.
18135
18136 *   dump initial particles for energy-momentum cons. check
18137       IF (LEMCCK) THEN
18138          CALL DT_EVTEMC(PPR(1),PPR(2),PPR(3),PPR(4),1,IDUM,IDUM)
18139          CALL DT_EVTEMC(PTA(1),PTA(2),PTA(3),PTA(4),2,IDUM,IDUM)
18140       ENDIF
18141
18142       AMP2 = PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2
18143       AMT2 = PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2
18144       IF ((AMP2.LT.ZERO).OR.(AMT2.LT.ZERO).OR.
18145      &    (ABS(AMP2-AAM(IDPR)**2).GT.TINY5).OR.
18146      &    (ABS(AMT2-AAM(IDTA)**2).GT.TINY5)) THEN
18147          IF (LMSSG.AND.(IOULEV(3).GT.0))
18148      &   WRITE(LOUT,1000) AMP2,AAM(IDPR)**2,AMT2,AAM(IDTA)**2
18149  1000    FORMAT(1X,'HADRIN:   warning! inconsistent projectile/target',
18150      &          ' mass',/,20X,'AMP2 = ',E12.4,', AAM(IDPR)**2 = ',
18151      &          E12.4,/,20X,'AMT2 = ',E12.4,', AAM(IDTA)**2 = ',E12.4)
18152          LMSSG = .FALSE.
18153          LCORR = .TRUE.
18154       ENDIF
18155
18156 * convert initial state particles into particles which can be
18157 * handled by HADRIN
18158       IDHPR = IDPR
18159       IDHTA = IDTA
18160       IF ((IDHPR.LE.0).OR.(IDHPR.GE.111).OR.LCORR) THEN
18161          IF ((IDHPR.LE.0).OR.(IDHPR.GE.111)) IDHPR = 1
18162          DO 1 K=1,4
18163             P1IN(K) = PPR(K)
18164             P2IN(K) = PTA(K)
18165     1    CONTINUE
18166          XM1 = AAM(IDHPR)
18167          XM2 = AAM(IDHTA)
18168          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18169          IF (IREJ1.GT.0) THEN
18170             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
18171             GOTO 9999
18172          ENDIF
18173          DO 2 K=1,4
18174             PPR(K) = P1OUT(K)
18175             PTA(K) = P2OUT(K)
18176     2    CONTINUE
18177          PPR(5) = SQRT(PPR(4)**2-PPR(1)**2-PPR(2)**2-PPR(3)**2)
18178          PTA(5) = SQRT(PTA(4)**2-PTA(1)**2-PTA(2)**2-PTA(3)**2)
18179       ENDIF
18180
18181 * Lorentz-parameter for trafo into rest-system of target
18182       DO 3 K=1,4
18183          BGTA(K) = PTA(K)/PTA(5)
18184     3 CONTINUE
18185 * transformation of projectile into rest-system of target
18186       CALL DT_DALTRA(BGTA(4),-BGTA(1),-BGTA(2),-BGTA(3),PPR(1),PPR(2),
18187      &            PPR(3),PPR(4),PPRTO1,PPR1(1),PPR1(2),PPR1(3),
18188      &            PPR1(4))
18189
18190 * direction cosines of projectile in target rest system
18191       CX = PPR1(1)/PPRTO1
18192       CY = PPR1(2)/PPRTO1
18193       CZ = PPR1(3)/PPRTO1
18194
18195 * sample inelastic interaction
18196       IF (MODE.EQ.1) THEN
18197          CALL DT_DHADRI(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA)
18198          IF (IRH.EQ.1) GOTO 9998
18199 * sample elastic interaction
18200       ELSEIF (MODE.EQ.2) THEN
18201          CALL DT_ELHAIN(IDHPR,PPRTO1,PPR1(4),CX,CY,CZ,IDHTA,IREJ1)
18202          IF (IREJ1.NE.0) THEN
18203             IF (IOULEV(1).GT.0) WRITE(LOUT,*) 'rejected 1 in HADRIN'
18204             GOTO 9999
18205          ENDIF
18206          IF (IRH.EQ.1) GOTO 9998
18207       ELSE
18208          WRITE(LOUT,1001) MODE,INTHAD
18209  1001    FORMAT(1X,'HADRIN:   warning! inconsistent interaction mode',
18210      &          I4,' (INTHAD =',I4,')')
18211          GOTO 9999
18212       ENDIF
18213
18214 * transform final state particles back into Lab.
18215       DO 4 I=1,IRH
18216          NFSP = NFSP+1
18217          PX   = CXRH(I)*PLRH(I)
18218          PY   = CYRH(I)*PLRH(I)
18219          PZ   = CZRH(I)*PLRH(I)
18220          CALL DT_DALTRA(BGTA(4),BGTA(1),BGTA(2),BGTA(3),
18221      &               PX,PY,PZ,ELRH(I),PTOFSP,PFSP(1,NFSP),
18222      &               PFSP(2,NFSP),PFSP(3,NFSP),PFSP(4,NFSP))
18223          IDFSP(NFSP) = ITRH(I)
18224          AMFSP2 = PFSP(4,NFSP)**2-PFSP(1,NFSP)**2-PFSP(2,NFSP)**2-
18225      &                                            PFSP(3,NFSP)**2
18226          IF (AMFSP2.LT.-TINY3) THEN
18227             WRITE(LOUT,1002) IDFSP(NFSP),PFSP(1,NFSP),PFSP(2,NFSP),
18228      &                       PFSP(3,NFSP),PFSP(4,NFSP),AMFSP2
18229  1002       FORMAT(1X,'HADRIN:   warning! final state particle (id = ',
18230      &             I2,') with negative mass^2',/,1X,5E12.4)
18231             GOTO 9999
18232          ELSE
18233             PFSP(5,NFSP) = SQRT(ABS(AMFSP2))
18234             IF (ABS(PFSP(5,NFSP)-AAM(IDFSP(NFSP))).GT.TINY1) THEN
18235                WRITE(LOUT,1003) IDFSP(NFSP),AAM(IDFSP(NFSP)),
18236      &                          PFSP(5,NFSP)
18237  1003          FORMAT(1X,'HADRIN:   warning! final state particle',
18238      &                ' (id = ',I2,') with inconsistent mass',/,1X,
18239      &                2E12.4)
18240                KCORR         = KCORR+1
18241                IF (KCORR.GT.2) GOTO 9999
18242                IMCORR(KCORR) = NFSP
18243             ENDIF
18244          ENDIF
18245 *   dump final state particles for energy-momentum cons. check
18246          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I),-PFSP(2,I),
18247      &                           -PFSP(3,I),-PFSP(4,I),2,IDUM,IDUM)
18248     4 CONTINUE
18249
18250 * transform momenta on mass shell in case of inconsistencies in
18251 * HADRIN
18252       IF (KCORR.GT.0) THEN
18253          IF (KCORR.EQ.2) THEN
18254             I1 = IMCORR(1)
18255             I2 = IMCORR(2)
18256          ELSE
18257             IF (IMCORR(1).EQ.1) THEN
18258                I1 = 1
18259                I2 = 2
18260             ELSE
18261                I1 = 1
18262                I2 = IMCORR(1)
18263             ENDIF
18264          ENDIF
18265          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I1),PFSP(2,I1),
18266      &                           PFSP(3,I1),PFSP(4,I1),2,IDUM,IDUM)
18267          IF (LEMCCK) CALL DT_EVTEMC(PFSP(1,I2),PFSP(2,I2),
18268      &                           PFSP(3,I2),PFSP(4,I2),2,IDUM,IDUM)
18269          DO 5 K=1,4
18270             P1IN(K) = PFSP(K,I1)
18271             P2IN(K) = PFSP(K,I2)
18272     5    CONTINUE
18273          XM1 = AAM(IDFSP(I1))
18274          XM2 = AAM(IDFSP(I2))
18275          CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
18276          IF (IREJ1.GT.0) THEN
18277             WRITE(LOUT,'(1X,A)') 'HADRIN:   inconsistent mass trsf.'
18278 C           GOTO 9999
18279          ENDIF
18280          DO 6 K=1,4
18281             PFSP(K,I1) = P1OUT(K)
18282             PFSP(K,I2) = P2OUT(K)
18283     6    CONTINUE
18284          PFSP(5,I1) = SQRT(PFSP(4,I1)**2-PFSP(1,I1)**2
18285      &                    -PFSP(2,I1)**2-PFSP(3,I1)**2)
18286          PFSP(5,I2) = SQRT(PFSP(4,I2)**2-PFSP(1,I2)**2
18287      &                    -PFSP(2,I2)**2-PFSP(3,I2)**2)
18288 *   dump final state particles for energy-momentum cons. check
18289          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I1),-PFSP(2,I1),
18290      &                           -PFSP(3,I1),-PFSP(4,I1),2,IDUM,IDUM)
18291          IF (LEMCCK) CALL DT_EVTEMC(-PFSP(1,I2),-PFSP(2,I2),
18292      &                           -PFSP(3,I2),-PFSP(4,I2),2,IDUM,IDUM)
18293       ENDIF
18294
18295 * check energy-momentum conservation
18296       IF (LEMCCK) THEN
18297          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,4,102,IREJ1)
18298          IF (IREJ1.NE.0) GOTO 9999
18299       ENDIF
18300
18301       RETURN
18302
18303  9998 CONTINUE
18304       IREJ = 2
18305       RETURN
18306
18307  9999 CONTINUE
18308       IREJ = 1
18309       RETURN
18310       END
18311
18312 *$ CREATE DT_HADCOL.FOR
18313 *COPY DT_HADCOL
18314 *
18315 *===hadcol=============================================================*
18316 *
18317       SUBROUTINE DT_HADCOL(IDPROJ,PPN,IDXTAR,IREJ)
18318
18319 ************************************************************************
18320 * Interface to the HADRIN-routines for inelastic and elastic           *
18321 * scattering. This subroutine samples hadron-nucleus interactions      *
18322 * below DPM-threshold.                                                 *
18323 *      IDPROJ        BAMJET-index of projectile hadron                 *
18324 *      PPN           projectile momentum in target rest frame          *
18325 *      IDXTAR        DTEVT1-index of target nucleon undergoing         *
18326 *                    interaction with projectile hadron                *
18327 * This subroutine replaces HADHAD.                                     *
18328 * This version dated 5.5.95 is written by S. Roesler                   *
18329 ************************************************************************
18330
18331       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18332       SAVE
18333
18334       PARAMETER ( LINP = 10 ,
18335      &            LOUT = 6 ,
18336      &            LDAT = 9 )
18337
18338       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,TINY3=1.0D-3,ONE=1.0D0)
18339
18340       LOGICAL LSTART
18341
18342 * event history
18343
18344       PARAMETER (NMXHKK=200000)
18345
18346       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18347      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18348      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18349
18350 * extended event history
18351       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18352      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18353      &                IHIST(2,NMXHKK)
18354
18355 * nuclear potential
18356       LOGICAL LFERMI
18357       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18358      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18359      &                ETACOU(2),ICOUL,LFERMI
18360
18361 * interface HADRIN-DPM
18362       COMMON /HNTHRE/ EHADTH,EHADLO,EHADHI,INTHAD,IDXTA
18363
18364 * parameter for intranuclear cascade
18365       LOGICAL LPAULI
18366       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
18367
18368 * final state after inc step
18369       PARAMETER (MAXFSP=10)
18370       COMMON /DTCAPA/ PFSP(5,MAXFSP),IDFSP(MAXFSP),NFSP
18371
18372 * particle properties (BAMJET index convention)
18373       CHARACTER*8  ANAME
18374       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18375      &                IICH(210),IIBAR(210),K1(210),K2(210)
18376
18377       DIMENSION PPROJ(5),PNUC(5)
18378
18379       DATA LSTART /.TRUE./
18380
18381       IREJ   = 0
18382
18383       NPOINT(1) = NHKK+1
18384
18385       TAUSAV = TAUFOR
18386 **sr 6/9/01 commented
18387 C     TAUFOR = TAUFOR/2.0D0
18388 **
18389       IF (LSTART) THEN
18390          WRITE(LOUT,1000)
18391  1000    FORMAT(/,1X,'HADCOL:  Scattering handled by HADRIN')
18392          WRITE(LOUT,1001) TAUFOR
18393  1001    FORMAT(/,1X,'HADCOL:  Formation zone parameter set to ',
18394      &          F5.1,' fm/c')
18395          LSTART = .FALSE.
18396       ENDIF
18397
18398       IDNUC  = IDBAM(IDXTAR)
18399       IDNUC1 = IDT_MCHAD(IDNUC)
18400       IDPRO1 = IDT_MCHAD(IDPROJ)
18401
18402       IF ((INTHAD.EQ.1).OR.(INTHAD.EQ.2)) THEN
18403          IPROC = INTHAD
18404       ELSE
18405 **
18406 C        CALL DT_SIHNIN(IDPRO1,IDNUC1,PPN,SIGIN)
18407 C        CALL DT_SIHNEL(IDPRO1,IDNUC1,PPN,SIGEL)
18408          DUMZER = ZERO
18409          CALL DT_XSHN(IDPRO1,IDNUC1,PPN,DUMZER,SIGTOT,SIGEL)
18410          SIGIN = SIGTOT-SIGEL
18411 C        SIGTOT = SIGIN+SIGEL
18412 **
18413          IPROC  = 1
18414          IF (DT_RNDM(SIGIN).LT.SIGEL/SIGTOT) IPROC = 2
18415       ENDIF
18416
18417       PPROJ(1) = ZERO
18418       PPROJ(2) = ZERO
18419       PPROJ(3) = PPN
18420       PPROJ(5) = AAM(IDPROJ)
18421       PPROJ(4) = SQRT(PPROJ(5)**2+PPROJ(3)**2)
18422       DO 1 K=1,5
18423          PNUC(K)  = PHKK(K,IDXTAR)
18424     1 CONTINUE
18425
18426       ILOOP = 0
18427     2 CONTINUE
18428       ILOOP = ILOOP+1
18429       IF (ILOOP.GT.100) GOTO 9999
18430
18431       CALL DT_HADRIN(IDPROJ,PPROJ,IDNUC,PNUC,IPROC,IREJ1)
18432       IF (IREJ1.EQ.1) GOTO 9999
18433
18434       IF (IREJ1.GT.1) THEN
18435 * no interaction possible
18436 *   require Pauli blocking
18437          IF ((IDPROJ.EQ.1).AND.(PPROJ(4).LE.PFERMP(2)+PPROJ(5))) GOTO 2
18438          IF ((IDPROJ.EQ.8).AND.(PPROJ(4).LE.PFERMN(2)+PPROJ(5))) GOTO 2
18439          IF ((IIBAR(IDPROJ).NE.1).AND.
18440      &       (PPROJ(4).LE.EPOT(2,IDPROJ)+PPROJ(5)))              GOTO 2
18441 *   store incoming particle as final state particle
18442          CALL DT_LTNUC(PPROJ(3),PPROJ(4),PCMS,ECMS,3)
18443          CALL DT_EVTPUT(1,IDPROJ,1,0,PPROJ(1),PPROJ(2),PCMS,ECMS,0,0,0)
18444          NPOINT(4) = NHKK
18445       ELSE
18446 * require Pauli blocking for final state nucleons
18447          DO 4 I=1,NFSP
18448             IF ((IDFSP(I).EQ.1).AND.
18449      &          (PFSP(4,I).LE.PFERMP(2)+AAM(IDFSP(I))))       GOTO 2
18450             IF ((IDFSP(I).EQ.8).AND.
18451      &          (PFSP(4,I).LE.PFERMN(2)+AAM(IDFSP(I))))       GOTO 2
18452             IF ((IIBAR(IDFSP(I)).NE.1).AND.
18453      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I))))GOTO 2
18454     4    CONTINUE
18455 * store final state particles
18456          DO 5 I=1,NFSP
18457             IST = 1
18458             IF ((IIBAR(IDFSP(I)).EQ.1).AND.
18459      &          (PFSP(4,I).LE.EPOT(2,IDFSP(I))+AAM(IDFSP(I)))) IST = 16
18460             IDHAD = IDT_IPDGHA(IDFSP(I))
18461             CALL DT_LTNUC(PFSP(3,I),PFSP(4,I),PCMS,ECMS,3)
18462             CALL DT_EVTPUT(IST,IDHAD,1,IDXTAR,PFSP(1,I),PFSP(2,I),
18463      &                                        PCMS,ECMS,0,0,0)
18464             IF (I.EQ.1) NPOINT(4) = NHKK
18465             VHKK(1,NHKK) = 0.5D0*(VHKK(1,1)+VHKK(1,IDXTAR))
18466             VHKK(2,NHKK) = 0.5D0*(VHKK(2,1)+VHKK(2,IDXTAR))
18467             VHKK(3,NHKK) = VHKK(3,IDXTAR)
18468             VHKK(4,NHKK) = VHKK(4,IDXTAR)
18469             WHKK(1,NHKK) = 0.5D0*(WHKK(1,1)+WHKK(1,IDXTAR))
18470             WHKK(2,NHKK) = 0.5D0*(WHKK(2,1)+WHKK(2,IDXTAR))
18471             WHKK(3,NHKK) = WHKK(3,1)
18472             WHKK(4,NHKK) = WHKK(4,1)
18473     5    CONTINUE
18474       ENDIF
18475       TAUFOR = TAUSAV
18476       RETURN
18477
18478  9999 CONTINUE
18479       IREJ = 1
18480       TAUFOR = TAUSAV
18481       RETURN
18482       END
18483 *$ CREATE DT_GETEMU.FOR
18484 *COPY DT_GETEMU
18485 *
18486 *===getemu=============================================================*
18487 *
18488       SUBROUTINE DT_GETEMU(IT,ITZ,KKMAT,MODE)
18489
18490 ************************************************************************
18491 * Sampling of emulsion component to be considered as target-nucleus.   *
18492 * This version dated 6.5.95   is written by S. Roesler.                *
18493 ************************************************************************
18494
18495       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18496       SAVE
18497
18498       PARAMETER ( LINP = 10 ,
18499      &            LOUT = 6 ,
18500      &            LDAT = 9 )
18501
18502       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
18503
18504       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
18505
18506 * emulsion treatment
18507       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
18508      &                NCOMPO,IEMUL
18509
18510 * Glauber formalism: flags and parameters for statistics
18511       LOGICAL LPROD
18512       CHARACTER*8 CGLB
18513       COMMON /DTGLGP/ JSTATB,JBINSB,CGLB,IOGLB,LPROD
18514
18515       IF (MODE.EQ.0) THEN
18516          SUMFRA = ZERO
18517          RR = DT_RNDM(SUMFRA)
18518          IT  = 0
18519          ITZ = 0
18520          DO 1 ICOMP=1,NCOMPO
18521             SUMFRA = SUMFRA+EMUFRA(ICOMP)
18522             IF (SUMFRA.GT.RR) THEN
18523                IT    = IEMUMA(ICOMP)
18524                ITZ   = IEMUCH(ICOMP)
18525                KKMAT = ICOMP
18526                GOTO 2
18527             ENDIF
18528     1    CONTINUE
18529     2    CONTINUE
18530          IF (IT.LE.0) THEN
18531             WRITE(LOUT,'(1X,A,E12.3)')
18532      &       'Warning!  norm. failure within emulsion fractions',
18533      &       SUMFRA
18534             STOP
18535          ENDIF
18536       ELSEIF (MODE.EQ.1) THEN
18537          NDIFF = 10000
18538          DO 3 I=1,NCOMPO
18539             IDIFF = ABS(IT-IEMUMA(I))
18540             IF (IDIFF.LT.NDIFF) THEN
18541                KKMAT = I
18542                NDIFF = IDIFF
18543             ENDIF
18544     3    CONTINUE
18545       ELSE
18546          STOP 'DT_GETEMU'
18547       ENDIF
18548
18549 * bypass for variable projectile/target/energy runs: the correct
18550 * Glauber data will be always loaded on kkmat=1
18551       IF (IOGLB.EQ.100) THEN
18552          KKMAT = 1
18553       ENDIF
18554
18555       RETURN
18556       END
18557
18558 *$ CREATE DT_NCLPOT.FOR
18559 *COPY DT_NCLPOT
18560 *
18561 *===nclpot=============================================================*
18562 *
18563       SUBROUTINE DT_NCLPOT(IPZ,IP,ITZ,IT,AFERP,AFERT,MODE)
18564
18565 ************************************************************************
18566 * Calculation of Coulomb and nuclear potential for a given configurat. *
18567 *               IPZ, IP       charge/mass number of proj.              *
18568 *               ITZ, IT       charge/mass number of targ.              *
18569 *               AFERP,AFERT   factors modifying proj./target pot.      *
18570 *                             if =0, FERMOD is used                    *
18571 *               MODE = 0      calculation of binding energy            *
18572 *                    = 1      pre-calculated binding energy is used    *
18573 * This version dated 16.11.95  is written by S. Roesler.               *
18574 *                                                                      *
18575 * Last change 28.12.2006 by S. Roesler.                                *
18576 ************************************************************************
18577
18578       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18579       SAVE
18580
18581       PARAMETER ( LINP = 10 ,
18582      &            LOUT = 6 ,
18583      &            LDAT = 9 )
18584
18585       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
18586      &           TINY10=1.0D-10)
18587
18588       LOGICAL LSTART
18589
18590 * particle properties (BAMJET index convention)
18591       CHARACTER*8  ANAME
18592       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18593      &                IICH(210),IIBAR(210),K1(210),K2(210)
18594
18595 * nuclear potential
18596       LOGICAL LFERMI
18597       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18598      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18599      &                ETACOU(2),ICOUL,LFERMI
18600
18601       DIMENSION IDXPOT(14)
18602 *                   ap   an  lam  alam sig- sig+ sig0 tet0 tet- asig-
18603       DATA IDXPOT /   2,   9,  17,  18,  20,  21,  22,  97,  98,  99,
18604 *                 asig0 asig+ atet0 atet+
18605      &              100, 101, 102, 103/
18606
18607       DATA AN     /0.4D0/
18608       DATA LSTART /.TRUE./
18609
18610       IF (MODE.EQ.0) THEN
18611          EBINDP(1) = ZERO
18612          EBINDN(1) = ZERO
18613          EBINDP(2) = ZERO
18614          EBINDN(2) = ZERO
18615       ENDIF
18616       AIP  = DBLE(IP)
18617       AIPZ = DBLE(IPZ)
18618       AIT  = DBLE(IT)
18619       AITZ = DBLE(ITZ)
18620
18621       FERMIP = AFERP
18622       IF (AFERP.LE.ZERO) FERMIP = FERMOD
18623       FERMIT = AFERT
18624       IF (AFERT.LE.ZERO) FERMIT = FERMOD
18625
18626 * Fermi momenta and binding energy for projectile
18627       IF ((IP.GT.1).AND.LFERMI) THEN
18628          IF (MODE.EQ.0) THEN
18629 C           EBINDP(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ-1)
18630 C           EBINDN(1) = DT_EBIND(IP,IPZ)-DT_EBIND(IP-1,IPZ)
18631             BIP  = AIP -ONE
18632             BIPZ = AIPZ-ONE
18633
18634 C           EBINDP(1) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIP,BIPZ)
18635 C    &                                         -ENERGY(AIP,AIPZ))
18636             EBINDP(1) = 1.0D-3*(EXMSAZ(ONE,ONE ,.TRUE.,IZDUM)
18637      &                         +EXMSAZ(BIP,BIPZ,.TRUE.,IZDUM)
18638      &                         -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18639
18640             IF (AIP.LE.AIPZ) THEN
18641                EBINDN(1) = EBINDP(1)
18642                WRITE(LOUT,*) ' DT_NCLPOT: AIP.LE.AIPZ (',AIP,AIPZ,')'
18643             ELSE
18644
18645 C              EBINDN(1) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIP,AIPZ)
18646 C    &                                             -ENERGY(AIP,AIPZ))
18647                EBINDN(1) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18648      &                            +EXMSAZ(BIP,AIPZ,.TRUE.,IZDUM)
18649      &                            -EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM))
18650
18651             ENDIF
18652          ENDIF
18653          PFERMP(1) = FERMIP*AN*(AIPZ/AIP)**0.333333D0
18654          PFERMN(1) = FERMIP*AN*((AIP-AIPZ)/AIP)**0.33333D0
18655       ELSE
18656          PFERMP(1) = ZERO
18657          PFERMN(1) = ZERO
18658       ENDIF
18659 * effective nuclear potential for projectile
18660 C     EPOT(1,1) = PFERMP(1)**2/(2.0D0*AAM(1)) + EBINDP(1)
18661 C     EPOT(1,8) = PFERMN(1)**2/(2.0D0*AAM(8)) + EBINDN(1)
18662       EPOT(1,1) = SQRT(PFERMP(1)**2+AAM(1)**2) -AAM(1) + EBINDP(1)
18663       EPOT(1,8) = SQRT(PFERMN(1)**2+AAM(8)**2) -AAM(8) + EBINDN(1)
18664
18665 * Fermi momenta and binding energy for target
18666       IF ((IT.GT.1).AND.LFERMI) THEN
18667          IF (MODE.EQ.0) THEN
18668 C           EBINDP(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ-1)
18669 C           EBINDN(2) = DT_EBIND(IT,ITZ)-DT_EBIND(IT-1,ITZ)
18670             BIT  = AIT -ONE
18671             BITZ = AITZ-ONE
18672
18673 C           EBINDP(2) = 1.0D-3*(ENERGY(ONE,ONE)+ENERGY(BIT,BITZ)
18674 C    &                                         -ENERGY(AIT,AITZ))
18675             EBINDP(2) = 1.0D-3*(EXMSAZ(ONE,ONE, .TRUE.,IZDUM)
18676      &                         +EXMSAZ(BIT,BITZ,.TRUE.,IZDUM)
18677      &                         -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18678
18679             IF (AIT.LE.AITZ) THEN
18680                EBINDN(2) = EBINDP(2)
18681                WRITE(LOUT,*) ' DT_NCLPOT: AIT.LE.AIPT (',AIT,AIPT,')'
18682             ELSE
18683
18684 C              EBINDN(2) = 1.0D-3*(ENERGY(ONE,ZERO)+ENERGY(BIT,AITZ)
18685 C    &                                             -ENERGY(AIT,AITZ))
18686                EBINDN(2) = 1.0D-3*(EXMSAZ(ONE,ZERO,.TRUE.,IZDUM)
18687      &                            +EXMSAZ(BIT,AITZ,.TRUE.,IZDUM)
18688      &                            -EXMSAZ(AIT,AITZ,.TRUE.,IZDUM))
18689
18690             ENDIF
18691          ENDIF
18692          PFERMP(2) = FERMIT*AN*(AITZ/AIT)**0.333333D0
18693          PFERMN(2) = FERMIT*AN*((AIT-AITZ)/AIT)**0.33333D0
18694       ELSE
18695          PFERMP(2) = ZERO
18696          PFERMN(2) = ZERO
18697       ENDIF
18698 * effective nuclear potential for target
18699 C     EPOT(2,1) = PFERMP(2)**2/(2.0D0*AAM(1)) + EBINDP(2)
18700 C     EPOT(2,8) = PFERMN(2)**2/(2.0D0*AAM(8)) + EBINDN(2)
18701       EPOT(2,1) = SQRT(PFERMP(2)**2+AAM(1)**2) -AAM(1) + EBINDP(2)
18702       EPOT(2,8) = SQRT(PFERMN(2)**2+AAM(8)**2) -AAM(8) + EBINDN(2)
18703
18704       DO 2 I=1,14
18705          EPOT(1,IDXPOT(I)) = EPOT(1,8)
18706          EPOT(2,IDXPOT(I)) = EPOT(2,8)
18707     2 CONTINUE
18708
18709 * Coulomb energy
18710       ETACOU(1) = ZERO
18711       ETACOU(2) = ZERO
18712       IF (ICOUL.EQ.1) THEN
18713          IF (IP.GT.1)
18714      &   ETACOU(1) = 0.001116D0*AIPZ/(1.0D0+AIP**0.333D0)
18715          IF (IT.GT.1)
18716      &   ETACOU(2) = 0.001116D0*AITZ/(1.0D0+AIT**0.333D0)
18717       ENDIF
18718
18719       IF (LSTART) THEN
18720          WRITE(LOUT,1000) IP,IPZ,IT,ITZ,EBINDP,EBINDN,
18721      &                    EPOT(1,1)-EBINDP(1),EPOT(2,1)-EBINDP(2),
18722      &                    EPOT(1,8)-EBINDN(1),EPOT(2,8)-EBINDN(2),
18723      &                    FERMOD,ETACOU
18724  1000    FORMAT(/,/,1X,'NCLPOT:    quantities for inclusion of nuclear'
18725      &           ,' effects',/,12X,'---------------------------',
18726      &           '----------------',/,/,38X,'projectile',
18727      &           '      target',/,/,1X,'Mass number / charge',
18728      &           17X,I3,' /',I3,6X,I3,' /',I3,/,1X,'Binding energy  -',
18729      &           ' proton   (GeV) ',2E14.4,/,17X,'- neutron  (GeV)'
18730      &          ,1X,2E14.4,/,1X,'Fermi-potential - proton   (GeV)',
18731      &           1X,2E14.4,/,17X,'- neutron  (GeV) ',2E14.4,/,/,
18732      &           1X,'Scale factor for Fermi-momentum    ',F4.2,/,
18733      &           /,1X,'Coulomb-energy ',2(E14.4,' GeV  '),/,/)
18734          LSTART = .FALSE.
18735       ENDIF
18736
18737       RETURN
18738       END
18739
18740 *$ CREATE DT_RESNCL.FOR
18741 *COPY DT_RESNCL
18742 *
18743 *===resncl=============================================================*
18744 *
18745       SUBROUTINE DT_RESNCL(EPN,NLOOP,MODE)
18746
18747 ************************************************************************
18748 * Treatment of residual nuclei and nuclear effects.                    *
18749 *         MODE = 1     initializations                                 *
18750 *              = 2     treatment of final state                        *
18751 * This version dated 16.11.95 is written by S. Roesler.                *
18752 *                                                                      *
18753 * Last change 05.01.2007 by S. Roesler.                                *
18754 ************************************************************************
18755
18756       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
18757       SAVE
18758
18759       PARAMETER ( LINP = 10 ,
18760      &            LOUT = 6 ,
18761      &            LDAT = 9 )
18762
18763       PARAMETER (ZERO=0.D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,TINY3=1.0D-3,
18764      &           TINY2=1.0D-2,TINY1=1.0D-1,TINY4=1.0D-4,TINY10=1.0D-10,
18765      &           ONETHI=ONE/THREE)
18766       PARAMETER (AMUAMU = 0.93149432D0,
18767      &           FM2MM  = 1.0D-12,
18768      &           RNUCLE = 1.12D0)
18769       PARAMETER ( EMVGEV = 1.0                D-03 )
18770       PARAMETER ( AMUGEV = 0.93149432         D+00 )
18771       PARAMETER ( AMPRTN = 0.93827231         D+00 )
18772       PARAMETER ( AMNTRN = 0.93956563         D+00 )
18773       PARAMETER ( AMELCT = 0.51099906         D-03 )
18774       PARAMETER ( HLFHLF = 0.5D+00 )
18775       PARAMETER ( FERTHO = 14.33       D-09 )
18776       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
18777       PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
18778       PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
18779
18780 * event history
18781
18782       PARAMETER (NMXHKK=200000)
18783
18784       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
18785      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
18786      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
18787
18788 * extended event history
18789       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
18790      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
18791      &                IHIST(2,NMXHKK)
18792
18793 * particle properties (BAMJET index convention)
18794       CHARACTER*8  ANAME
18795       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
18796      &                IICH(210),IIBAR(210),K1(210),K2(210)
18797
18798 * flags for input different options
18799       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
18800       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
18801      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
18802
18803 * nuclear potential
18804       LOGICAL LFERMI
18805       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
18806      &                EBINDP(2),EBINDN(2),EPOT(2,210),
18807      &                ETACOU(2),ICOUL,LFERMI
18808
18809 * properties of interacting particles
18810       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
18811
18812 * properties of photon/lepton projectiles
18813       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
18814
18815 * Lorentz-parameters of the current interaction
18816       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
18817      &                UMO,PPCM,EPROJ,PPROJ
18818
18819 * treatment of residual nuclei: wounded nucleons
18820       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
18821
18822 * treatment of residual nuclei: 4-momenta
18823       LOGICAL LRCLPR,LRCLTA
18824       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
18825      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
18826
18827       DIMENSION PFSP(4),PSEC(4),PSEC0(4)
18828       DIMENSION PMOMB(5000),IDXB(5000),PMOMM(10000),IDXM(10000),
18829      &          IDXCOR(15000),IDXOTH(NMXHKK)
18830
18831       GOTO (1,2) MODE
18832
18833 *------- initializations
18834     1 CONTINUE
18835
18836 * initialize arrays for residual nuclei
18837       DO 10 K=1,5
18838          IF (K.LE.4) THEN
18839             PFSP(K)     = ZERO
18840          ENDIF
18841          PINIPR(K) = ZERO
18842          PINITA(K) = ZERO
18843          PRCLPR(K) = ZERO
18844          PRCLTA(K) = ZERO
18845          TRCLPR(K) = ZERO
18846          TRCLTA(K) = ZERO
18847    10 CONTINUE
18848       SCPOT = ONE
18849       NLOOP = 0
18850
18851 * correction of projectile 4-momentum for effective target pot.
18852 * and Coulomb-energy (in case of hadron-nucleus interaction only)
18853       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
18854          EPNI = EPN
18855 *   Coulomb-energy:
18856 *     positively charged hadron - check energy for Coloumb pot.
18857          IF (IICH(IJPROJ).EQ.1) THEN
18858             THRESH = ETACOU(2)+AAM(IJPROJ)
18859             IF (EPNI.LE.THRESH) THEN
18860                WRITE(LOUT,1000)
18861  1000          FORMAT(/,1X,'KKINC:  WARNING!  projectile energy',
18862      &                ' below Coulomb threshold - event rejected',/)
18863                ISTHKK(1) = 1
18864                RETURN
18865             ENDIF
18866 *     negatively charged hadron - increase energy by Coulomb energy
18867          ELSEIF (IICH(IJPROJ).EQ.-1) THEN
18868             EPNI = EPNI+ETACOU(2)
18869          ENDIF
18870          IF ((IJPROJ.EQ.1).OR.(IJPROJ.EQ.8)) THEN
18871 *   Effective target potential
18872 *sr 6.6. binding energy only (to avoid negative exc. energies)
18873 C           EPNI = EPNI+EPOT(2,IJPROJ)
18874             EBIPOT = EBINDP(2)
18875             IF ((IJPROJ.NE.1).AND.(ABS(EPOT(2,IJPROJ)).GT.5.0D-3))
18876      &         EBIPOT = EBINDN(2)
18877             EPNI = EPNI+ABS(EBIPOT)
18878 * re-initialization of DTLTRA
18879             DUM1 = ZERO
18880             DUM2 = ZERO
18881             CALL DT_LTINI(IJPROJ,IJTARG,EPNI,DUM1,DUM2,0)
18882          ENDIF
18883       ENDIF
18884
18885 * projectile in n-n cms
18886       IF ((IP.LE.1).AND.(IT.GT.1)) THEN
18887          PMASS1 = AAM(IJPROJ)
18888 C* VDM assumption
18889 C         IF (IJPROJ.EQ.7) PMASS1 = AAM(33)
18890          IF (IJPROJ.EQ.7) PMASS1 = AAM(IJPROJ)-SQRT(VIRT)
18891          PMASS2 = AAM(1)
18892          PM1 = SIGN(PMASS1**2,PMASS1)
18893          PM2 = SIGN(PMASS2**2,PMASS2)
18894          PINIPR(4) = (UMO**2-PM2+PM1)/(TWO*UMO)
18895          PINIPR(5) = PMASS1
18896          IF (PMASS1.GT.ZERO) THEN
18897             PINIPR(3) = SQRT((PINIPR(4)-PINIPR(5))
18898      &                      *(PINIPR(4)+PINIPR(5)))
18899          ELSE
18900             PINIPR(3) = SQRT(PINIPR(4)**2-PM1)
18901          ENDIF
18902          AIT  = DBLE(IT)
18903          AITZ = DBLE(ITZ)
18904
18905 C        PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18906          PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18907
18908          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18909       ELSEIF ((IP.GT.1).AND.(IT.LE.1)) THEN
18910          PMASS1 = AAM(1)
18911          PMASS2 = AAM(IJTARG)
18912          PM1 = SIGN(PMASS1**2,PMASS1)
18913          PM2 = SIGN(PMASS2**2,PMASS2)
18914          PINITA(4) = (UMO**2-PM1+PM2)/(TWO*UMO)
18915          PINITA(5) = PMASS2
18916          PINITA(3) = -SQRT((PINITA(4)-PINITA(5))
18917      &                    *(PINITA(4)+PINITA(5)))
18918          AIP  = DBLE(IP)
18919          AIPZ = DBLE(IPZ)
18920
18921 C        PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18922          PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18923
18924          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18925       ELSEIF ((IP.GT.1).AND.(IT.GT.1)) THEN
18926          AIP  = DBLE(IP)
18927          AIPZ = DBLE(IPZ)
18928
18929 C        PINIPR(5) = AIP*AMUAMU+1.0D-3*ENERGY(AIP,AIPZ)
18930          PINIPR(5) = AIP*AMUC12+EMVGEV*EXMSAZ(AIP,AIPZ,.TRUE.,IZDUM)
18931
18932          CALL DT_LTNUC(ZERO,PINIPR(5),PINIPR(3),PINIPR(4),2)
18933          AIT  = DBLE(IT)
18934          AITZ = DBLE(ITZ)
18935
18936 C        PINITA(5) = AIT*AMUAMU+1.0D-3*ENERGY(AIT,AITZ)
18937          PINITA(5) = AIT*AMUC12+EMVGEV*EXMSAZ(AIT,AITZ,.TRUE.,IZDUM)
18938
18939          CALL DT_LTNUC(ZERO,PINITA(5),PINITA(3),PINITA(4),3)
18940       ENDIF
18941
18942       RETURN
18943
18944 *------- treatment of final state
18945     2 CONTINUE
18946
18947       NLOOP = NLOOP+1
18948       IF (NLOOP.GT.1) SCPOT = 0.10D0
18949 C     WRITE(LOUT,*) 'event ',NEVHKK,NLOOP,SCPOT
18950
18951       JPW  = NPW
18952       JPCW = NPCW
18953       JTW  = NTW
18954       JTCW = NTCW
18955       DO 40 K=1,4
18956          PFSP(K)   = ZERO
18957    40 CONTINUE
18958
18959       NOB = 0
18960       NOM = 0
18961       DO 900 I=NPOINT(4),NHKK
18962          IDXOTH(I) = -1
18963          IF (ISTHKK(I).EQ.1) THEN
18964             IF (IDBAM(I).EQ.7) GOTO 900
18965             IPOT = 0
18966             IOTHER = 0
18967 * particle moving into forward direction
18968             IF (PHKK(3,I).GE.ZERO) THEN
18969 *   most likely to be effected by projectile potential
18970                IPOT = 1
18971 *     there is no projectile nucleus, try target
18972                IF ((IP.LE.1).OR.((IP-NPW).LE.1)) THEN
18973                   IPOT   = 2
18974                   IF (IP.GT.1) IOTHER = 1
18975 *       there is no target nucleus --> skip
18976                   IF ((IT.LE.1).OR.((IT-NTW).LE.1)) GOTO 900
18977                ENDIF
18978 * particle moving into backward direction
18979             ELSE
18980 *   most likely to be effected by target potential
18981                IPOT = 2
18982 *     there is no target nucleus, try projectile
18983                IF ((IT.LE.1).OR.((IT-NTW).LE.1)) THEN
18984                   IPOT   = 1
18985                   IF (IT.GT.1) IOTHER = 1
18986 *       there is no projectile nucleus --> skip
18987                   IF ((IP.LE.1).OR.((IP-NPW).LE.1)) GOTO 900
18988                ENDIF
18989             ENDIF
18990             IFLG = -IPOT
18991 * nobam=3: particle is in overlap-region or neither inside proj. nor target
18992 *      =1: particle is not in overlap-region AND is inside target (2)
18993 *      =2: particle is not in overlap-region AND is inside projectile (1)
18994 * flag particles which are inside the nucleus ipot but not in its
18995 * overlap region
18996             IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) IFLG = IPOT
18997             IF (IDBAM(I).NE.0) THEN
18998 * baryons: keep all nucleons and all others where flag is set
18999                IF (IIBAR(IDBAM(I)).NE.0) THEN
19000                   IF ((IDBAM(I).EQ.1).OR.(IDBAM(I).EQ.8).OR.(IFLG.GT.0))
19001      &                                                              THEN
19002                      NOB = NOB+1
19003                      PMOMB(NOB) = PHKK(3,I)
19004                      IDXB(NOB)  = SIGN(10000000*IABS(IFLG)
19005      &                           +1000000*IOTHER+I,IFLG)
19006                   ENDIF
19007 * mesons: keep only those mesons where flag is set
19008                ELSE
19009                   IF (IFLG.GT.0) THEN
19010                      NOM = NOM+1
19011                      PMOMM(NOM) = PHKK(3,I)
19012                      IDXM(NOM)  = 10000000*IFLG+1000000*IOTHER+I
19013                   ENDIF
19014                ENDIF
19015             ENDIF
19016          ENDIF
19017   900 CONTINUE
19018 *
19019 * sort particles in the arrays according to increasing long. momentum
19020       CALL DT_SORT1(PMOMB,IDXB,NOB,1,NOB,1)
19021       CALL DT_SORT1(PMOMM,IDXM,NOM,1,NOM,1)
19022 *
19023 * shuffle indices into one and the same array according to the later
19024 * sequence of correction
19025       NCOR = 0
19026       IF (IT.GT.1) THEN
19027          DO 910 I=1,NOB
19028             IF (PMOMB(I).GT.ZERO) GOTO 911
19029             NCOR = NCOR+1
19030             IDXCOR(NCOR) = IDXB(I)
19031   910    CONTINUE
19032   911    CONTINUE
19033          IF (IP.GT.1) THEN
19034             DO 912 J=1,NOB
19035                I = NOB+1-J
19036                IF (PMOMB(I).LT.ZERO) GOTO 913
19037                NCOR = NCOR+1
19038                IDXCOR(NCOR) = IDXB(I)
19039   912       CONTINUE
19040   913       CONTINUE
19041          ELSE
19042             DO 914 I=1,NOB
19043                IF (PMOMB(I).GT.ZERO) THEN
19044                   NCOR = NCOR+1
19045                   IDXCOR(NCOR) = IDXB(I)
19046                ENDIF
19047   914       CONTINUE
19048          ENDIF
19049       ELSE
19050          DO 915 J=1,NOB
19051             I = NOB+1-J
19052             NCOR = NCOR+1
19053             IDXCOR(NCOR) = IDXB(I)
19054   915    CONTINUE
19055       ENDIF
19056       DO 925 I=1,NOM
19057          IF (PMOMM(I).GT.ZERO) GOTO 926
19058          NCOR = NCOR+1
19059          IDXCOR(NCOR) = IDXM(I)
19060   925 CONTINUE
19061   926 CONTINUE
19062       DO 927 J=1,NOM
19063          I = NOM+1-J
19064          IF (PMOMM(I).LT.ZERO) GOTO 928
19065          NCOR = NCOR+1
19066          IDXCOR(NCOR) = IDXM(I)
19067   927 CONTINUE
19068   928 CONTINUE
19069 *
19070 C      IF (NEVHKK.EQ.484) THEN
19071 C         WRITE(LOUT,9000) JPCW,JPW-JPCW,JTCW,JTW-JTCW
19072 C 9000    FORMAT(1X,'wounded nucleons (proj.-p,n  targ.-p,n)',/,4I10)
19073 C         WRITE(LOUT,9001) NOB,NOM,NCOR
19074 C 9001    FORMAT(1X,'produced particles (baryons,mesons,all)',3I10)
19075 C         WRITE(LOUT,'(/,A)') ' baryons '
19076 C         DO 950 I=1,NOB
19077 CC           J     = IABS(IDXB(I))
19078 CC           INDEX = J-IABS(J/10000000)*10000000
19079 C            IPOT   = IABS(IDXB(I))/10000000
19080 C            IOTHER = IABS(IDXB(I))/1000000-IPOT*10
19081 C            INDEX = IABS(IDXB(I))-IPOT*10000000-IOTHER*1000000
19082 C            WRITE(LOUT,9002) I,INDEX,IDXB(I),IDBAM(INDEX),PMOMB(I)
19083 C  950    CONTINUE
19084 C         WRITE(LOUT,'(/,A)') ' mesons '
19085 C         DO 951 I=1,NOM
19086 CC           INDEX = IDXM(I)-IABS(IDXM(I)/10000000)*10000000
19087 C            IPOT   = IABS(IDXM(I))/10000000
19088 C            IOTHER = IABS(IDXM(I))/1000000-IPOT*10
19089 C            INDEX = IABS(IDXM(I))-IPOT*10000000-IOTHER*1000000
19090 C            WRITE(LOUT,9002) I,INDEX,IDXM(I),IDBAM(INDEX),PMOMM(I)
19091 C  951    CONTINUE
19092 C 9002    FORMAT(1X,4I14,E14.5)
19093 C         WRITE(LOUT,'(/,A)') ' all '
19094 C         DO 952 I=1,NCOR
19095 CC           J     = IABS(IDXCOR(I))
19096 CC           INDEX = J-IABS(J/10000000)*10000000
19097 CC            IPOT   = IABS(IDXCOR(I))/10000000
19098 C            IOTHER = IABS(IDXCOR(I))/1000000-IPOT*10
19099 C            INDEX = IABS(IDXCOR(I))-IPOT*10000000-IOTHER*1000000
19100 C            WRITE(LOUT,9003) I,INDEX,IDXCOR(I),IDBAM(INDEX)
19101 C  952    CONTINUE
19102 C 9003    FORMAT(1X,4I14)
19103 C      ENDIF
19104 *
19105       DO 20 ICOR=1,NCOR
19106          IPOT   = IABS(IDXCOR(ICOR))/10000000
19107          IOTHER = IABS(IDXCOR(ICOR))/1000000-IPOT*10
19108          I = IABS(IDXCOR(ICOR))-IPOT*10000000-IOTHER*1000000
19109          IDXOTH(I) = 1
19110
19111          IDSEC  = IDBAM(I)
19112
19113 * reduction of particle momentum by corresponding nuclear potential
19114 * (this applies only if Fermi-momenta are requested)
19115
19116          IF (LFERMI) THEN
19117
19118 *   Lorentz-transformation into the rest system of the selected nucleus
19119             IMODE = -IPOT-1
19120             CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19121      &                  PSEC(1),PSEC(2),PSEC(3),PSEC(4),IDSEC,IMODE)
19122             PSECO  = SQRT(PSEC(1)**2+PSEC(2)**2+PSEC(3)**2)
19123             AMSEC  = SQRT(ABS((PSEC(4)-PSECO)*(PSEC(4)+PSECO)))
19124             JPMOD  = 0
19125
19126             CHKLEV = TINY3
19127             IF ((EPROJ.GE.1.0D4).AND.(IDSEC.EQ.7)) CHKLEV = TINY1
19128             IF (EPROJ.GE.2.0D6) CHKLEV = 1.0D0
19129             IF (ABS(AMSEC-AAM(IDSEC)).GT.CHKLEV) THEN
19130                IF (IOULEV(3).GT.0)
19131      &            WRITE(LOUT,2000) I,NEVHKK,IDSEC,AMSEC,AAM(IDSEC)
19132  2000          FORMAT(1X,'RESNCL: inconsistent mass of particle',
19133      &                ' at entry ',I5,' (evt.',I8,')',/,' IDSEC: ',
19134      &                I4,'   AMSEC: ',E12.3,'  AAM(IDSEC): ',E12.3,/)
19135                GOTO 23
19136             ENDIF
19137
19138             DO 21 K=1,4
19139                PSEC0(K) = PSEC(K)
19140    21       CONTINUE
19141
19142 *   the correction for nuclear potential effects is applied to as many
19143 *   p/n as many nucleons were wounded; the momenta of other final state
19144 *   particles are corrected only if they materialize inside the corresp.
19145 *   nucleus (here: NOBAM = 1 part. outside proj., = 2 part. outside targ
19146 *   = 3 part. outside proj. and targ., >=10 in overlapping region)
19147             IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) THEN
19148                IF (IPOT.EQ.1) THEN
19149                   IF ((JPW.GT.0).AND.(IOTHER.EQ.0)) THEN
19150 *      this is most likely a wounded nucleon
19151 **test
19152 C                    RDIST = SQRT((VHKK(1,IPW(JPW))/FM2MM)**2
19153 C    &                           +(VHKK(2,IPW(JPW))/FM2MM)**2
19154 C    &                           +(VHKK(3,IPW(JPW))/FM2MM)**2)
19155 C                    RAD   = RNUCLE*DBLE(IP)**ONETHI
19156 C                    FDEN  = 1.4D0*DT_DENSIT(IP,RDIST,RAD)
19157 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19158 **
19159                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19160                      JPW = JPW-1
19161                      JPMOD = 1
19162                   ELSE
19163 *      correct only if part. was materialized inside nucleus
19164 *      and if it is ouside the overlapping region
19165                      IF ((NOBAM(I).NE.1).AND.(NOBAM(I).LT.3)) THEN
19166                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19167                         JPMOD = 1
19168                      ENDIF
19169                   ENDIF
19170                ELSEIF (IPOT.EQ.2) THEN
19171                   IF ((JTW.GT.0).AND.(IOTHER.EQ.0)) THEN
19172 *      this is most likely a wounded nucleon
19173 **test
19174 C                    RDIST = SQRT((VHKK(1,ITW(JTW))/FM2MM)**2
19175 C    &                           +(VHKK(2,ITW(JTW))/FM2MM)**2
19176 C    &                           +(VHKK(3,ITW(JTW))/FM2MM)**2)
19177 C                    RAD   = RNUCLE*DBLE(IT)**ONETHI
19178 C                    FDEN  = 1.4D0*DT_DENSIT(IT,RDIST,RAD)
19179 C                    PSEC(4) = PSEC(4)-SCPOT*FDEN*EPOT(IPOT,IDSEC)
19180 **
19181                      PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19182                      JTW = JTW-1
19183                      JPMOD = 1
19184                   ELSE
19185 *      correct only if part. was materialized inside nucleus
19186                      IF ((NOBAM(I).NE.2).AND.(NOBAM(I).LT.3)) THEN
19187                         PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19188                         JPMOD = 1
19189                      ENDIF
19190                   ENDIF
19191                ENDIF
19192             ELSE
19193                IF ((NOBAM(I).NE.IPOT).AND.(NOBAM(I).LT.3)) THEN
19194                   PSEC(4) = PSEC(4)-SCPOT*EPOT(IPOT,IDSEC)
19195                   JPMOD = 1
19196                ENDIF
19197             ENDIF
19198
19199             IF (NLOOP.EQ.1) THEN
19200 * Coulomb energy correction:
19201 * the treatment of Coulomb potential correction is similar to the
19202 * one for nuclear potential
19203                IF (IDSEC.EQ.1) THEN
19204                   IF ((IPOT.EQ.1).AND.(JPCW.GT.0)) THEN
19205                      JPCW = JPCW-1
19206                   ELSEIF ((IPOT.EQ.2).AND.(JTCW.GT.0)) THEN
19207                      JTCW = JTCW-1
19208                   ELSE
19209                      IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19210                   ENDIF
19211                ELSE
19212                   IF ((NOBAM(I).EQ.IPOT).OR.(NOBAM(I).EQ.3)) GOTO 25
19213                ENDIF
19214                IF (IICH(IDSEC).EQ.1) THEN
19215 *    pos. particles: check if they are able to escape Coulomb potential
19216                   IF (PSEC(4).LT.AMSEC+ETACOU(IPOT)) THEN
19217                      ISTHKK(I) = 14+IPOT
19218                      IF (ISTHKK(I).EQ.15) THEN
19219                         DO 26 K=1,4
19220                            PHKK(K,I) = PSEC0(K)
19221                            TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19222    26                CONTINUE
19223                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19224                         IF (IDSEC.EQ.1) NPCW = NPCW-1
19225                      ELSEIF (ISTHKK(I).EQ.16) THEN
19226                         DO 27 K=1,4
19227                            PHKK(K,I) = PSEC0(K)
19228                            TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19229    27                   CONTINUE
19230                         IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19231                         IF (IDSEC.EQ.1) NTCW = NTCW-1
19232                      ENDIF
19233                      GOTO 20
19234                   ENDIF
19235                ELSEIF (IICH(IDSEC).EQ.-1) THEN
19236 *    neg. particles: decrease energy by Coulomb-potential
19237                   PSEC(4) = PSEC(4)-ETACOU(IPOT)
19238                   JPMOD = 1
19239                ENDIF
19240             ENDIF
19241
19242    25       CONTINUE
19243
19244             IF (PSEC(4).LT.AMSEC) THEN
19245                IF (IOULEV(6).GT.0)
19246      &            WRITE(LOUT,2001) I,IDSEC,PSEC(4),AMSEC
19247  2001          FORMAT(1X,'KKINC: particle at DTEVT1-pos. ',I5,
19248      &                ' is not allowed to escape nucleus',/,
19249      &                8X,'id : ',I3,'   reduced energy: ',E15.4,
19250      &                '   mass: ',E12.3)
19251                ISTHKK(I) = 14+IPOT
19252                IF (ISTHKK(I).EQ.15) THEN
19253                   DO 28 K=1,4
19254                      PHKK(K,I) = PSEC0(K)
19255                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)
19256    28             CONTINUE
19257                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NPW = NPW-1
19258                   IF (IDSEC.EQ.1) NPCW = NPCW-1
19259                ELSEIF (ISTHKK(I).EQ.16) THEN
19260                   DO 29 K=1,4
19261                      PHKK(K,I) = PSEC0(K)
19262                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)
19263    29             CONTINUE
19264                   IF ((IDSEC.EQ.1).OR.(IDSEC.EQ.8)) NTW = NTW-1
19265                   IF (IDSEC.EQ.1) NTCW = NTCW-1
19266                ENDIF
19267                GOTO 20
19268             ENDIF
19269
19270             IF (JPMOD.EQ.1) THEN
19271                PSECN  = SQRT( (PSEC(4)-AMSEC)*(PSEC(4)+AMSEC) )
19272 * 4-momentum after correction for nuclear potential
19273                DO 22 K=1,3
19274                   PSEC(K) = PSEC(K)*PSECN/PSECO
19275    22          CONTINUE
19276
19277 * store recoil momentum from particles escaping the nuclear potentials
19278                DO 30 K=1,4
19279                   IF (IPOT.EQ.1) THEN
19280                      TRCLPR(K) = TRCLPR(K)+PSEC0(K)-PSEC(K)
19281                   ELSEIF (IPOT.EQ.2) THEN
19282                      TRCLTA(K) = TRCLTA(K)+PSEC0(K)-PSEC(K)
19283                   ENDIF
19284    30          CONTINUE
19285
19286 * transform momentum back into n-n cms
19287                IMODE = IPOT+1
19288                CALL DT_LTRANS(PSEC(1),PSEC(2),PSEC(3),PSEC(4),
19289      &                     PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
19290      &                     IDSEC,IMODE)
19291             ENDIF
19292
19293          ENDIF
19294
19295    23    CONTINUE
19296          DO 31 K=1,4
19297             PFSP(K) = PFSP(K)+PHKK(K,I)
19298    31    CONTINUE
19299
19300    20 CONTINUE
19301
19302       DO 33 I=NPOINT(4),NHKK
19303          IF ((ISTHKK(I).EQ.1).AND.(IDXOTH(I).LT.0)) THEN
19304             PFSP(1) = PFSP(1)+PHKK(1,I)
19305             PFSP(2) = PFSP(2)+PHKK(2,I)
19306             PFSP(3) = PFSP(3)+PHKK(3,I)
19307             PFSP(4) = PFSP(4)+PHKK(4,I)
19308          ENDIF
19309    33 CONTINUE
19310
19311       DO 34 K=1,5
19312          PRCLPR(K) = TRCLPR(K)
19313          PRCLTA(K) = TRCLTA(K)
19314    34 CONTINUE
19315
19316       IF ((IP.EQ.1).AND.(IT.GT.1).AND.LFERMI) THEN
19317 * hadron-nucleus interactions: get residual momentum from energy-
19318 * momentum conservation
19319          DO 32 K=1,4
19320             PRCLPR(K) = ZERO
19321             PRCLTA(K) = PINIPR(K)+PINITA(K)-PFSP(K)
19322    32    CONTINUE
19323       ELSE
19324 * nucleus-hadron, nucleus-nucleus: get residual momentum from
19325 * accumulated recoil momenta of particles leaving the spectators
19326 *   transform accumulated recoil momenta of residual nuclei into
19327 *   n-n cms
19328          PZI = PRCLPR(3)
19329          PEI = PRCLPR(4)
19330          CALL DT_LTNUC(PZI,PEI,PRCLPR(3),PRCLPR(4),2)
19331          PZI = PRCLTA(3)
19332          PEI = PRCLTA(4)
19333          CALL DT_LTNUC(PZI,PEI,PRCLTA(3),PRCLTA(4),3)
19334 C        IF (IP.GT.1) THEN
19335             PRCLPR(3) = PRCLPR(3)+PINIPR(3)
19336             PRCLPR(4) = PRCLPR(4)+PINIPR(4)
19337 C        ENDIF
19338          IF (IT.GT.1) THEN
19339             PRCLTA(3) = PRCLTA(3)+PINITA(3)
19340             PRCLTA(4) = PRCLTA(4)+PINITA(4)
19341          ENDIF
19342       ENDIF
19343
19344 * check momenta of residual nuclei
19345       IF (LEMCCK) THEN
19346          CALL DT_EVTEMC(-PINIPR(1),-PINIPR(2),-PINIPR(3),-PINIPR(4),
19347      &               1,IDUM,IDUM)
19348          CALL DT_EVTEMC(-PINITA(1),-PINITA(2),-PINITA(3),-PINITA(4),
19349      &               2,IDUM,IDUM)
19350          CALL DT_EVTEMC(PRCLPR(1),PRCLPR(2),PRCLPR(3),PRCLPR(4),
19351      &               2,IDUM,IDUM)
19352          CALL DT_EVTEMC(PRCLTA(1),PRCLTA(2),PRCLTA(3),PRCLTA(4),
19353      &               2,IDUM,IDUM)
19354          CALL DT_EVTEMC(PFSP(1),PFSP(2),PFSP(3),PFSP(4),2,IDUM,IDUM)
19355 **sr 19.12. changed to avoid output when used with phojet
19356 C        CHKLEV = TINY3
19357          CHKLEV = TINY1
19358          CALL DT_EVTEMC(DUM,DUM,DUM,CHKLEV,-1,501,IREJ1)
19359 C        IF ((NEVHKK.EQ.409).OR.(NEVHKK.EQ.460).OR.(NEVHKK.EQ.765))
19360 C    &      CALL DT_EVTOUT(4)
19361          IF (IREJ1.GT.0) RETURN
19362       ENDIF
19363
19364       RETURN
19365       END
19366
19367 *$ CREATE DT_SCN4BA.FOR
19368 *COPY DT_SCN4BA
19369 *
19370 *===scn4ba=============================================================*
19371 *
19372       SUBROUTINE DT_SCN4BA
19373
19374 ************************************************************************
19375 * SCan /DTEVT1/ 4 BAryons which are not able to escape nuclear pot.    *
19376 * This version dated 12.12.95 is written by S. Roesler.                *
19377 ************************************************************************
19378
19379       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19380       SAVE
19381
19382       PARAMETER ( LINP = 10 ,
19383      &            LOUT = 6 ,
19384      &            LDAT = 9 )
19385
19386       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY2=1.0D-2,
19387      &           TINY10=1.0D-10)
19388
19389 * event history
19390
19391       PARAMETER (NMXHKK=200000)
19392
19393       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19394      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19395      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19396
19397 * extended event history
19398       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19399      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19400      &                IHIST(2,NMXHKK)
19401
19402 * particle properties (BAMJET index convention)
19403       CHARACTER*8  ANAME
19404       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19405      &                IICH(210),IIBAR(210),K1(210),K2(210)
19406
19407 * properties of interacting particles
19408       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
19409
19410 * nuclear potential
19411       LOGICAL LFERMI
19412       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
19413      &                EBINDP(2),EBINDN(2),EPOT(2,210),
19414      &                ETACOU(2),ICOUL,LFERMI
19415
19416 * treatment of residual nuclei: wounded nucleons
19417       COMMON /DTWOUN/ NPW,NPW0,NPCW,NTW,NTW0,NTCW,IPW(210),ITW(210)
19418
19419 * treatment of residual nuclei: 4-momenta
19420       LOGICAL LRCLPR,LRCLTA
19421       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19422      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19423
19424       DIMENSION PLAB(2,5),PCMS(4)
19425
19426       IREJ = 0
19427
19428 * get number of wounded nucleons
19429       NPW    = 0
19430       NPW0   = 0
19431       NPCW   = 0
19432       NPSTCK = 0
19433       NTW    = 0
19434       NTW0   = 0
19435       NTCW   = 0
19436       NTSTCK = 0
19437
19438       ISGLPR = 0
19439       ISGLTA = 0
19440       LRCLPR = .FALSE.
19441       LRCLTA = .FALSE.
19442
19443 C     DO 2 I=1,NHKK
19444       DO 2 I=1,NPOINT(1)
19445 * projectile nucleons wounded in primary interaction and in fzc
19446          IF ((ISTHKK(I).EQ.11).OR.(ISTHKK(I).EQ.17)) THEN
19447             NPW      = NPW+1
19448             IPW(NPW) = I
19449             NPSTCK   = NPSTCK+1
19450             IF (IDHKK(I).EQ.2212) NPCW = NPCW+1
19451             IF (ISTHKK(I).EQ.11)  NPW0 = NPW0+1
19452 C           IF (IP.GT.1) THEN
19453                DO 5 K=1,4
19454                   TRCLPR(K) = TRCLPR(K)-PHKK(K,I)
19455     5          CONTINUE
19456 C           ENDIF
19457 * target nucleons wounded in primary interaction and in fzc
19458          ELSEIF ((ISTHKK(I).EQ.12).OR.(ISTHKK(I).EQ.18)) THEN
19459             NTW      = NTW+1
19460             ITW(NTW) = I
19461             NTSTCK   = NTSTCK+1
19462             IF (IDHKK(I).EQ.2212) NTCW = NTCW+1
19463             IF (ISTHKK(I).EQ.12)  NTW0 = NTW0+1
19464             IF (IT.GT.1) THEN
19465                DO 6 K=1,4
19466                   TRCLTA(K) = TRCLTA(K)-PHKK(K,I)
19467     6          CONTINUE
19468             ENDIF
19469          ELSEIF (ISTHKK(I).EQ.13) THEN
19470             ISGLPR = I
19471          ELSEIF (ISTHKK(I).EQ.14) THEN
19472             ISGLTA = I
19473          ENDIF
19474     2 CONTINUE
19475
19476       DO 11 I=NPOINT(4),NHKK
19477 * baryons which are unable to escape the nuclear potential of proj.
19478          IF (ISTHKK(I).EQ.15) THEN
19479             ISGLPR = I
19480             NPSTCK = NPSTCK-1
19481             IF (IIBAR(IDBAM(I)).NE.0) THEN
19482                NPW    = NPW-1
19483                IF (IICH(IDBAM(I)).GT.0) NPCW = NPCW-1
19484             ENDIF
19485             DO 7 K=1,4
19486                TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19487     7       CONTINUE
19488 * baryons which are unable to escape the nuclear potential of targ.
19489          ELSEIF (ISTHKK(I).EQ.16) THEN
19490             ISGLTA = I
19491             NTSTCK = NTSTCK-1
19492             IF (IIBAR(IDBAM(I)).NE.0) THEN
19493                NTW    = NTW-1
19494                IF (IICH(IDBAM(I)).GT.0) NTCW = NTCW-1
19495             ENDIF
19496             DO 8 K=1,4
19497                TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19498     8       CONTINUE
19499          ENDIF
19500    11 CONTINUE
19501
19502 * residual nuclei so far
19503       IRESP = IP-NPSTCK
19504       IREST = IT-NTSTCK
19505
19506 * ckeck for "residual nuclei" consisting of one nucleon only
19507 * treat it as final state particle
19508       IF (IRESP.EQ.1) THEN
19509          ID  = IDBAM(ISGLPR)
19510          IST = ISTHKK(ISGLPR)
19511          CALL DT_LTRANS(PHKK(1,ISGLPR),PHKK(2,ISGLPR),
19512      &               PHKK(3,ISGLPR),PHKK(4,ISGLPR),
19513      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,2)
19514          IF (IST.EQ.13) THEN
19515             ISTHKK(ISGLPR) = 11
19516          ELSE
19517             ISTHKK(ISGLPR) = 2
19518          ENDIF
19519          CALL DT_EVTPUT(1,IDHKK(ISGLPR),ISGLPR,0,
19520      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19521      &               IDRES(ISGLPR),IDXRES(ISGLPR),IDCH(ISGLPR))
19522          NOBAM(NHKK)      = NOBAM(ISGLPR)
19523          JDAHKK(1,ISGLPR) = NHKK
19524          DO 21 K=1,4
19525             TRCLPR(K) = TRCLPR(K)-PHKK(K,ISGLPR)
19526    21    CONTINUE
19527       ENDIF
19528       IF (IREST.EQ.1) THEN
19529          ID  = IDBAM(ISGLTA)
19530          IST = ISTHKK(ISGLTA)
19531          CALL DT_LTRANS(PHKK(1,ISGLTA),PHKK(2,ISGLTA),
19532      &               PHKK(3,ISGLTA),PHKK(4,ISGLTA),
19533      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),ID,3)
19534          IF (IST.EQ.14) THEN
19535             ISTHKK(ISGLTA) = 12
19536          ELSE
19537             ISTHKK(ISGLTA) = 2
19538          ENDIF
19539          CALL DT_EVTPUT(1,IDHKK(ISGLTA),ISGLTA,0,
19540      &               PCMS(1),PCMS(2),PCMS(3),PCMS(4),
19541      &               IDRES(ISGLTA),IDXRES(ISGLTA),IDCH(ISGLTA))
19542          NOBAM(NHKK)      = NOBAM(ISGLTA)
19543          JDAHKK(1,ISGLTA) = NHKK
19544          DO 22 K=1,4
19545             TRCLTA(K) = TRCLTA(K)-PHKK(K,ISGLTA)
19546    22    CONTINUE
19547       ENDIF
19548
19549 * get nuclear potential corresp. to the residual nucleus
19550       IPRCL  = IP -NPW
19551       IPZRCL = IPZ-NPCW
19552       ITRCL  = IT -NTW
19553       ITZRCL = ITZ-NTCW
19554       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,ZERO,ZERO,1)
19555
19556 * baryons unable to escape the nuclear potential are treated as
19557 * excited nucleons (ISTHKK=15,16)
19558       DO 3 I=NPOINT(4),NHKK
19559          IF (ISTHKK(I).EQ.1) THEN
19560             ID  = IDBAM(I)
19561             IF ( ((ID.EQ.1).OR.(ID.EQ.8)).AND.(NOBAM(I).NE.3) ) THEN
19562 *   final state n and p not being outside of both nuclei are considered
19563                NPOTP = 1
19564                NPOTT = 1
19565                IF ( (IP.GT.1)      .AND.(IRESP.GT.1).AND.
19566      &              (NOBAM(I).NE.1).AND.(NPW.GT.0)        ) THEN
19567 *     Lorentz-trsf. into proj. rest sys. for those being inside proj.
19568                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19569      &                        PHKK(4,I),PLAB(1,1),PLAB(1,2),PLAB(1,3),
19570      &                        PLAB(1,4),ID,-2)
19571                   PLABT = SQRT(PLAB(1,1)**2+PLAB(1,2)**2+PLAB(1,3)**2)
19572                   PLAB(1,5) = SQRT(ABS( (PLAB(1,4)-PLABT)*
19573      &                                  (PLAB(1,4)+PLABT) ))
19574                   EKIN = PLAB(1,4)-PLAB(1,5)
19575                   IF (EKIN.LE.EPOT(1,ID)) NPOTP = 15
19576                   IF ((ID.EQ.1).AND.(NPCW.LE.0)) NPOTP = 1
19577                ENDIF
19578                IF ( (IT.GT.1)      .AND.(IREST.GT.1).AND.
19579      &              (NOBAM(I).NE.2).AND.(NTW.GT.0)        ) THEN
19580 *     Lorentz-trsf. into targ. rest sys. for those being inside targ.
19581                   CALL DT_LTRANS(PHKK(1,I),PHKK(2,I),PHKK(3,I),
19582      &                        PHKK(4,I),PLAB(2,1),PLAB(2,2),PLAB(2,3),
19583      &                        PLAB(2,4),ID,-3)
19584                   PLABT = SQRT(PLAB(2,1)**2+PLAB(2,2)**2+PLAB(2,3)**2)
19585                   PLAB(2,5) = SQRT(ABS( (PLAB(2,4)-PLABT)*
19586      &                                  (PLAB(2,4)+PLABT) ))
19587                   EKIN = PLAB(2,4)-PLAB(2,5)
19588                   IF (EKIN.LE.EPOT(2,ID)) NPOTT = 16
19589                   IF ((ID.EQ.1).AND.(NTCW.LE.0)) NPOTT = 1
19590                ENDIF
19591                IF (PHKK(3,I).GE.ZERO) THEN
19592                   ISTHKK(I) = NPOTT
19593                   IF (NPOTP.NE.1) ISTHKK(I) = NPOTP
19594                ELSE
19595                   ISTHKK(I) = NPOTP
19596                   IF (NPOTT.NE.1) ISTHKK(I) = NPOTT
19597                ENDIF
19598                IF (ISTHKK(I).NE.1) THEN
19599                   J = ISTHKK(I)-14
19600                   DO 4 K=1,5
19601                      PHKK(K,I) = PLAB(J,K)
19602     4             CONTINUE
19603                   IF (ISTHKK(I).EQ.15) THEN
19604                      NPW = NPW-1
19605                      IF (ID.EQ.1) NPCW = NPCW-1
19606                      DO 9 K=1,4
19607                         TRCLPR(K) = TRCLPR(K)+PHKK(K,I)
19608     9                CONTINUE
19609                   ELSEIF (ISTHKK(I).EQ.16) THEN
19610                      NTW = NTW-1
19611                      IF (ID.EQ.1) NTCW = NTCW-1
19612                      DO 10 K=1,4
19613                         TRCLTA(K) = TRCLTA(K)+PHKK(K,I)
19614    10                CONTINUE
19615                   ENDIF
19616                ENDIF
19617             ENDIF
19618          ENDIF
19619     3 CONTINUE
19620
19621 * again: get nuclear potential corresp. to the residual nucleus
19622       IPRCL  = IP -NPW
19623       IPZRCL = IPZ-NPCW
19624       ITRCL  = IT -NTW
19625       ITZRCL = ITZ-NTCW
19626 c      AFERP = 1.2D0*FERMOD*(ONE+(DBLE(IP+10-NPW0)/DBLE(IP+10))**1.1D0)
19627 cC     AFERP = 1.21D0*FERMOD*(ONE+(DBLE(IP+40-NPW0)/DBLE(IP+40))**1.1D0)
19628 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NPW0)/5.0D0)) /2.0D0
19629 C     AFERP = 0.0D0
19630 c      AFERT = 1.2D0*FERMOD*(ONE+(DBLE(IT+10-NTW0)/DBLE(IT+10))**1.1D0)
19631 cC     AFERT = 1.21D0*FERMOD*(ONE+(DBLE(IT+40-NTW0)/DBLE(IT+40))**1.1D0)
19632 c     &             *(0.94D0+0.3D0*EXP(-DBLE(NTW0)/5.0D0)) /2.0D0
19633 C     AFERT = 0.0D0
19634 C     IF (AFERP.LT.FERMOD) AFERP = FERMOD+0.1
19635 C     IF (AFERT.LT.FERMOD) AFERT = FERMOD+0.1
19636 C     IF (AFERP.GT.0.85D0) AFERP = 0.85D0
19637 C     IF (AFERT.GT.0.85D0) AFERT = 0.85D0
19638       AFERP = FERMOD+0.1D0
19639       AFERT = FERMOD+0.1D0
19640
19641       CALL DT_NCLPOT(IPZRCL,IPRCL,ITZRCL,ITRCL,AFERP,AFERT,1)
19642
19643       RETURN
19644       END
19645
19646 *$ CREATE DT_FICONF.FOR
19647 *COPY DT_FICONF
19648 *
19649 *===ficonf=============================================================*
19650 *
19651       SUBROUTINE DT_FICONF(IJPROJ,IP,IPZ,IT,ITZ,NLOOP,IREJ)
19652
19653 ************************************************************************
19654 * Treatment of FInal CONFiguration including evaporation, fission and  *
19655 * Fermi-break-up (for light nuclei only).                              *
19656 * Adopted from the original routine FINALE and extended to residual    *
19657 * projectile nuclei.                                                   *
19658 * This version dated 12.12.95 is written by S. Roesler.                *
19659 *                                                                      *
19660 * Last change 27.12.2006 by S. Roesler.                                *
19661 ************************************************************************
19662
19663       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
19664       SAVE
19665
19666       PARAMETER ( LINP = 10 ,
19667      &            LOUT = 6 ,
19668      &            LDAT = 9 )
19669
19670       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
19671       PARAMETER (ANGLGB=5.0D-16)
19672
19673 * event history
19674
19675       PARAMETER (NMXHKK=200000)
19676
19677       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
19678      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
19679      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
19680
19681 * extended event history
19682       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
19683      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
19684      &                IHIST(2,NMXHKK)
19685
19686 * rejection counter
19687       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
19688      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
19689      &                IREXCI(3),IRDIFF(2),IRINC
19690
19691 * central particle production, impact parameter biasing
19692       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
19693
19694 * particle properties (BAMJET index convention)
19695       CHARACTER*8  ANAME
19696       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
19697      &                IICH(210),IIBAR(210),K1(210),K2(210)
19698
19699 * treatment of residual nuclei: 4-momenta
19700       LOGICAL LRCLPR,LRCLTA
19701       COMMON /DTRNU1/ PINIPR(5),PINITA(5),PRCLPR(5),PRCLTA(5),
19702      &                TRCLPR(5),TRCLTA(5),LRCLPR,LRCLTA
19703
19704 * treatment of residual nuclei: properties of residual nuclei
19705       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
19706      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
19707      &                NTOTFI(2),NPROFI(2)
19708
19709 * statistics: residual nuclei
19710       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
19711      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
19712      &                NINCST(2,4),NINCEV(2),
19713      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
19714      &                NRESPB(2),NRESCH(2),NRESEV(4),
19715      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
19716      &                NEVAFI(2,2)
19717
19718 * flags for input different options
19719       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
19720       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
19721      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
19722
19723 *      INCLUDE '(DIMPAR)'
19724 *     DIMPAR taken from FLUKA
19725       PARAMETER ( MXXRGN =20000 )
19726       PARAMETER ( MXXMDF =  710 )
19727       PARAMETER ( MXXMDE =  702 )
19728       PARAMETER ( MFSTCK =40000 )
19729       PARAMETER ( MESTCK =  100 )
19730       PARAMETER ( MOSTCK = 2000 )
19731       PARAMETER ( MXPRSN =  100 )
19732       PARAMETER ( MXPDPM =  800 )
19733       PARAMETER ( MXPSCS =30000 )
19734       PARAMETER ( MXGLWN =  300 )
19735       PARAMETER ( MXOUTU =   50 )
19736       PARAMETER ( NALLWP =   64 )
19737       PARAMETER ( NELEMX =   80 )
19738       PARAMETER ( MPDPDX =   18 )
19739       PARAMETER ( MXHTTR =  260 )
19740       PARAMETER ( MXSEAX =   20 )
19741       PARAMETER ( MXHTNC = MXSEAX + 1 )
19742       PARAMETER ( ICOMAX = 2400 )
19743       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
19744       PARAMETER ( NSTBIS =  304 )
19745       PARAMETER ( NQSTIS =   46 )
19746       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
19747       PARAMETER ( MXPABL =  120 )
19748       PARAMETER ( IDMAXP =  450 )
19749       PARAMETER ( IDMXDC = 2000 )
19750       PARAMETER ( MXMCIN =  410 )
19751       PARAMETER ( IHYPMX =    4 )
19752       PARAMETER ( MKBMX1 =   11 )
19753       PARAMETER ( MKBMX2 =   11 )
19754       PARAMETER ( MXIRRD = 2500 )
19755       PARAMETER ( MXTRDC = 1500 )
19756       PARAMETER ( NKTL   =   17 )
19757       PARAMETER ( NBLNMX = 40000000 )
19758
19759 *      INCLUDE '(GENSTK)'
19760 *     GENSTK taken from FLUKA
19761       COMMON / GENSTK /                CXR    (MXPSCS), CYR    (MXPSCS),
19762      &                CZR    (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
19763      &                CZRPOL (MXPSCS), TKI    (MXPSCS), PLR    (MXPSCS),
19764      &                WEI    (MXPSCS), AGESEC (MXPSCS), TV    , TVCMS  ,
19765      &                TVRECL,  TVHEAV, TVBIND,
19766      &                KPART  (MXPSCS), INFEXT (MXPSCS), NP0   , NP
19767
19768 *      INCLUDE '(RESNUC)'
19769 *     RESNUC from FLUKA
19770       LOGICAL LRNFSS, LFRAGM
19771       COMMON /RESNUC/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
19772      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
19773      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
19774      &                  PYRES,  PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
19775      &                 ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
19776      &                  KTARP,  KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
19777      &                 IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,  ICRES,
19778      &                  IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
19779      &                 IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
19780      &                 IEV4HE, IDEEXG,  IBTAR, ICHTAR, IBLEFT, ICLEFT,
19781      &                 ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
19782      &                 LRNFSS, LFRAGM
19783
19784       PARAMETER ( EMVGEV = 1.0                D-03 )
19785       PARAMETER ( AMUGEV = 0.93149432         D+00 )
19786       PARAMETER ( AMPRTN = 0.93827231         D+00 )
19787       PARAMETER ( AMNTRN = 0.93956563         D+00 )
19788       PARAMETER ( AMELCT = 0.51099906         D-03 )
19789       PARAMETER ( ELCCGS = 4.8032068          D-10 )
19790       PARAMETER ( ELCMKS = 1.60217733         D-19 )
19791       PARAMETER ( COUGFM = ELCCGS * ELCCGS / ELCMKS * 1.D-07 * 1.D+13
19792      &                   * 1.D-09 )
19793       PARAMETER ( HLFHLF = 0.5D+00 )
19794       PARAMETER ( FERTHO = 14.33       D-09 )
19795       PARAMETER ( BEXC12 = FERTHO * 72.40715579499394D+00 )
19796       PARAMETER ( AMUNMU = HLFHLF * AMELCT - BEXC12 / 12.D+00 )
19797       PARAMETER ( AMUC12 = AMUGEV - AMUNMU )
19798
19799 *      INCLUDE '(NUCDAT)'
19800 *     Taken from FLUKA
19801       PARAMETER ( AMUAMU = AMUGEV )
19802       PARAMETER ( AMPROT = AMPRTN )
19803       PARAMETER ( AMNEUT = AMNTRN )
19804       PARAMETER ( AMELEC = AMELCT )
19805       PARAMETER ( R0NUCL = 1.12        D+00 )
19806       PARAMETER ( RCCOUL = 1.7         D+00 )
19807       PARAMETER ( COULPR = COUGFM )
19808       PARAMETER ( AMHYDR = AMPRTN + AMELCT  )
19809       PARAMETER ( AMHTON = AMHYDR - AMNTRN  )
19810       PARAMETER ( AMNTOU = AMNTRN - AMUC12  )
19811       PARAMETER ( AMUCSQ = AMUC12 * AMUC12 )
19812       PARAMETER ( EBNDAV = HLFHLF * (AMPRTN + AMNTRN) - AMUC12 )
19813 *   Gammin : threshold for deexcitation gammas production, set to 1 keV
19814 *   (this means that up to 1 keV of energy unbalancing can occur
19815 *    during an event)
19816       PARAMETER ( GAMMIN = 1.0D-06 )
19817       PARAMETER ( GAMNSQ = 2.0D+00 * GAMMIN * GAMMIN )
19818 *   Tvepsi : "epsilon" for excitation energy, set to gammin / 100
19819       PARAMETER ( TVEPSI = GAMMIN / 100.D+00 )
19820 *
19821       COMMON /NUCDAT/ AV0WEL,     APFRMX,     AEFRMX,     AEFRMA,
19822      &                RDSNUC,     V0WELL (2), PFRMMX (2), EFRMMX (2),
19823      &                EFRMAV (2), AMNUCL (2), AMNUSQ (2), EBNDNG (2),
19824      &                VEFFNU (2), ESLOPE (2), PKMNNU (2), EKMNNU (2),
19825      &                PKMXNU (2), EKMXNU (2), EKMNAV (2), EKINAV (2),
19826      &                EXMNAV (2), EKUPNU (2), EXMNNU (2), EXUPNU (2),
19827      &                ERCLAV (2), ESWELL (2), FINCUP (2), AMRCAV    ,
19828      &                AMRCSQ    , ATO1O3    , ZTO1O3    , FRMRFC    ,
19829      &                ELBNDE (0:110)
19830
19831 *      INCLUDE '(PAREVT)'
19832 *     Taken from FLUKA
19833       PARAMETER ( FRDIFF = 0.2D+00 )
19834       PARAMETER ( ETHSEA = 1.0D+00 )
19835 *
19836       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
19837      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
19838      &        LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
19839      &        LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
19840       COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
19841      &                  LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
19842      &                  LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
19843      &                  LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
19844      &                  LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
19845      &                  LVP2XX, LV2XNW, LNWV2X, LEVFIN
19846
19847 *      INCLUDE '(FHEAVY)'
19848 *     Taken from FLUKA
19849       PARAMETER ( MXHEAV = 100 )
19850       PARAMETER ( KXHEAV =  30 )
19851       CHARACTER*8 ANHEAV
19852       COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
19853      &                  CZHEAV (MXHEAV), TKHEAV (MXHEAV),
19854      &                  PHEAVY (MXHEAV), WHEAVY (MXHEAV),
19855      &                  AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
19856      &                  AMHEAV (KXHEAV), AMNHEA (KXHEAV),
19857      &                  KHEAVY (MXHEAV), INFHEA (MXHEAV),
19858      &                  ICHEAV (KXHEAV), IBHEAV (KXHEAV),
19859      &                  IMHEAV (KXHEAV), IHHEAV (KXHEAV),
19860      &                  KHHEAV (IHYPMX,KXHEAV), NPHEAV
19861       COMMON / FHEAVC / ANHEAV (KXHEAV)
19862
19863 * event flag
19864       COMMON /DTEVNO/ NEVENT,ICASCA
19865
19866       DIMENSION INUC(2),IDXPAR(2),IDPAR(2),AIF(2),AIZF(2),AMRCL(2),
19867      &          PRCL(2,4),MO1(2),MO2(2),VRCL(2,4),WRCL(2,4),
19868      &          P1IN(4),P2IN(4),P1OUT(4),P2OUT(4)
19869
19870       DIMENSION EXPNUC(2),EXC(2,260),NEXC(2,260)
19871       LOGICAL LLCPOT
19872       DATA EXC,NEXC /520*ZERO,520*0/
19873       DATA EXPNUC /4.0D-3,4.0D-3/
19874
19875       IREJ   = 0
19876       LRCLPR = .FALSE.
19877       LRCLTA = .FALSE.
19878
19879 * skip residual nucleus treatment if not requested or in case
19880 * of central collisions
19881       IF ((.NOT.LEVPRT).OR.(ICENTR.GT.0).OR.(ICENTR.EQ.-1)) RETURN
19882
19883       DO 1 K=1,2
19884          IDPAR(K) = 0
19885          IDXPAR(K)= 0
19886          NTOT(K)  = 0
19887          NTOTFI(K)= 0
19888          NPRO(K)  = 0
19889          NPROFI(K)= 0
19890          NN(K)    = 0
19891          NH(K)    = 0
19892          NHPOS(K) = 0
19893          NQ(K)    = 0
19894          EEXC(K)  = ZERO
19895          MO1(K)   = 0
19896          MO2(K)   = 0
19897          DO 2 I=1,4
19898             VRCL(K,I) = ZERO
19899             WRCL(K,I) = ZERO
19900     2    CONTINUE
19901     1 CONTINUE
19902       NFSP = 0
19903       INUC(1) = IP
19904       INUC(2) = IT
19905
19906       DO 3 I=1,NHKK
19907
19908 * number of final state particles
19909          IF (ABS(ISTHKK(I)).EQ.1) THEN
19910             NFSP  = NFSP+1
19911             IDFSP = IDBAM(I)
19912          ENDIF
19913
19914 * properties of remaining nucleon configurations
19915          KF = 0
19916          IF ((ISTHKK(I).EQ.13).OR.(ISTHKK(I).EQ.15)) KF = 1
19917          IF ((ISTHKK(I).EQ.14).OR.(ISTHKK(I).EQ.16)) KF = 2
19918          IF (KF.GT.0) THEN
19919             IF (MO1(KF).EQ.0) MO1(KF) = I
19920             MO2(KF)  = I
19921 *   position of residual nucleus = average position of nucleons
19922             DO 4 K=1,4
19923                VRCL(KF,K) = VRCL(KF,K)+VHKK(K,I)
19924                WRCL(KF,K) = WRCL(KF,K)+WHKK(K,I)
19925     4       CONTINUE
19926 *   total number of particles contributing to each residual nucleus
19927             NTOT(KF)  = NTOT(KF)+1
19928             IDTMP     = IDBAM(I)
19929             IDXTMP    = I
19930 *   total charge of residual nuclei
19931             NQ(KF) = NQ(KF)+IICH(IDTMP)
19932 *   number of protons
19933             IF (IDHKK(I).EQ.2212) THEN
19934                NPRO(KF) = NPRO(KF)+1
19935 *   number of neutrons
19936             ELSEIF (IDHKK(I).EQ.2112) THEN
19937                NN(KF) = NN(KF)+1
19938             ELSE
19939 *   number of baryons other than n, p
19940                IF (IIBAR(IDTMP).EQ.1) THEN
19941                   NH(KF) = NH(KF)+1
19942                   IF (IICH(IDTMP).EQ.1) NHPOS(KF) = NHPOS(KF)+1
19943                ELSE
19944 *   any other mesons (status set to 1)
19945 C                 WRITE(LOUT,1002) KF,IDTMP
19946 C1002             FORMAT(1X,'FICONF:   residual nucleus ',I2,
19947 C    &                   ' containing meson ',I4,', status set to 1')
19948                   ISTHKK(I) = 1
19949                   IDTMP     = IDPAR(KF)
19950                   IDXTMP    = IDXPAR(KF)
19951                   NTOT(KF)  = NTOT(KF)-1
19952                ENDIF
19953             ENDIF
19954             IDPAR(KF)  = IDTMP
19955             IDXPAR(KF) = IDXTMP
19956          ENDIF
19957     3 CONTINUE
19958
19959 * reject elastic events (def: one final state particle = projectile)
19960       IF ((IP.EQ.1).AND.(NFSP.EQ.1).AND.(IDFSP.EQ.IJPROJ)) THEN
19961          IREXCI(3) = IREXCI(3)+1
19962          GOTO 9999
19963 C        RETURN
19964       ENDIF
19965
19966 * check if one nucleus disappeared..
19967 C     IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
19968 C        DO 5 K=1,4
19969 C           PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
19970 C           PRCLPR(K) = ZERO
19971 C   5    CONTINUE
19972 C     ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
19973 C        DO 6 K=1,4
19974 C           PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
19975 C           PRCLTA(K) = ZERO
19976 C   6    CONTINUE
19977 C     ENDIF
19978
19979       ICOR   = 0
19980       INORCL = 0
19981       DO 7 I=1,2
19982          DO 8 K=1,4
19983 * get the average of the nucleon positions
19984             VRCL(I,K) = VRCL(I,K)/MAX(NTOT(I),1)
19985             WRCL(I,K) = WRCL(I,K)/MAX(NTOT(I),1)
19986             IF (I.EQ.1) PRCL(1,K) = PRCLPR(K)
19987             IF (I.EQ.2) PRCL(2,K) = PRCLTA(K)
19988     8    CONTINUE
19989 * mass number and charge of residual nuclei
19990          AIF(I)  = DBLE(NTOT(I))
19991          AIZF(I) = DBLE(NPRO(I)+NHPOS(I))
19992          IF (NTOT(I).GT.1) THEN
19993 * masses of residual nuclei in ground state
19994
19995 C           AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I))
19996             AMRCL0(I) = AIF(I)*AMUC12
19997      &                  +EMVGEV*EXMSAZ(AIF(I),AIZF(I),.TRUE.,IZDUM)
19998
19999 * masses of residual nuclei
20000             PTORCL   = SQRT(PRCL(I,1)**2+PRCL(I,2)**2+PRCL(I,3)**2)
20001             AMRCL(I) = (PRCL(I,4)-PTORCL)*(PRCL(I,4)+PTORCL)
20002             IF (AMRCL(I).GT.ZERO) AMRCL(I) = SQRT(AMRCL(I))
20003 *
20004 *   M_res^2 < 0 : configuration not allowed
20005 *
20006 *      a) re-calculate E_exc with scaled nuclear potential
20007 *         (conditional jump to label 9998)
20008 *      b) or reject event if N_loop(max) is exceeded
20009 *         (conditional jump to label 9999)
20010 *
20011             IF (AMRCL(I).LE.ZERO) THEN
20012                IF (IOULEV(3).GT.0)
20013      &            WRITE(LOUT,1000) I,PRCL(I,1),PRCL(I,2),PRCL(I,3),
20014      &                             PRCL(I,4),NTOT
20015  1000          FORMAT(1X,'warning! negative excitation energy',/,
20016      &                I4,4E15.4,2I4)
20017                AMRCL(I) = ZERO
20018                EEXC(I)  = ZERO
20019                IF (NLOOP.LE.500) THEN
20020                   GOTO 9998
20021                ELSE
20022                   IREXCI(2) = IREXCI(2)+1
20023                   GOTO 9999
20024                ENDIF
20025 *
20026 *   0 < M_res < M_res0 : mass below ground-state mass
20027 *
20028 *      a) we had residual nuclei with mass N_tot and reasonable E_exc
20029 *         before- assign average E_exc of those configurations to this
20030 *         one ( Nexc(i,N_tot) > 0 )
20031 *      b) or (and this applies always if run in transport codes) go up
20032 *         one mass number and
20033 *           i) if mass now larger than proj/targ mass or if run in
20034 *              transport codes assign average E_exc per wounded nucleon
20035 *              x number of wounded nucleons (Inuc-Ntot)
20036 *          ii) or assign average E_exc of those configurations to this
20037 *              one ( Nexc(i,m) > 0 )
20038 *
20039             ELSEIF ((AMRCL(I).GT.ZERO).AND.(AMRCL(I).LT.AMRCL0(I)))
20040      &                                                         THEN
20041                M = MIN(NTOT(I),260)
20042                IF (NEXC(I,M).GT.0) THEN
20043                   AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20044                ELSE
20045    70             CONTINUE
20046                   M = M+1
20047 **sr corrected 27.12.06
20048 *                 IF (M.GE.INUC(I)) THEN
20049 *                    AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
20050                   IF ((M.GE.INUC(I)).OR.(ICASCA.GT.0)) THEN
20051                      IF ( INUC (I) .GT. NTOT (I) ) THEN
20052                         AMRCL(I) = AMRCL0(I)
20053      &                         + EXPNUC(I)*DBLE(MAX(INUC(I)-NTOT(I),0))
20054                      ELSE
20055                         AMRCL(I) = AMRCL0(I) + 0.5D+00 * EXPNUC(I)
20056                      END IF
20057 **
20058                   ELSE
20059                      IF (NEXC(I,M).GT.0) THEN
20060                         AMRCL(I) = AMRCL0(I)+EXC(I,M)/DBLE(NEXC(I,M))
20061                      ELSE
20062                         GOTO 70
20063                      ENDIF
20064                   ENDIF
20065                ENDIF
20066                EEXC(I)  = AMRCL(I)-AMRCL0(I)
20067                ICOR     = ICOR+I
20068 *
20069 *   M_res > 2.5 x M_res0 : unreasonably(?) high E_exc
20070 *
20071 *      a) re-calculate E_exc with scaled nuclear potential
20072 *         (conditional jump to label 9998)
20073 *      b) or reject event if N_loop(max) is exceeded
20074 *         (conditional jump to label 9999)
20075 *
20076 *
20077             ELSEIF (AMRCL(I).GE.2.5D0*AMRCL0(I)) THEN
20078                IF (IOULEV(3).GT.0)
20079      &            WRITE(LOUT,1004) I,AMRCL(I),AMRCL0(I),NTOT,NEVHKK
20080  1004          FORMAT(1X,'warning! too high excitation energy',/,
20081      &                I4,1P,2E15.4,3I5)
20082                AMRCL(I) = ZERO
20083                EEXC(I)  = ZERO
20084                IF (NLOOP.LE.500) THEN
20085                   GOTO 9998
20086                ELSE
20087                   IREXCI(2) = IREXCI(2)+1
20088                   GOTO 9999
20089                ENDIF
20090 *
20091 *   Otherwise (reasonable E_exc) :
20092 *      E_exc = M_res - M_res0
20093 *      in addition: calculate and save E_exc per wounded nucleon as
20094 *                   well as E_exc in <E_exc> counter
20095 *
20096             ELSE
20097 * excitation energies of residual nuclei
20098                EEXC(I)   = AMRCL(I)-AMRCL0(I)
20099 **sr 27.12.06 new excitation energy correction by A.F.
20100 *
20101 * all parts with Ilcopt<3 commented since not used
20102 *
20103 * still to be done/decided:
20104 *   Increase Icor and put back both residual nuclei on mass shell
20105 *   with the exciting correction further below.
20106 *   For the moment the modification in the excitation energy is simply
20107 *   corrected by scaling the energy of the residual nucleus.
20108 *
20109                LLCPOT = .TRUE.
20110                ILCOPT = 3
20111                IF ( LLCPOT ) THEN
20112                   NNCHIT = MAX ( INUC (I) - NTOT (I), 0 )
20113                   IF ( ILCOPT .LE. 2 ) THEN
20114 C* Patch for Fermi momentum reduction correlated with impact parameter:
20115 C                     FRMRDC = MIN ( (PFRMAV(INUC(I))/APFRMX)**3, ONE )
20116 C                     DLKPRH = 0.1D+00 + 0.5D+00 / SQRT(DBLE(INUC(I)))
20117 C                     AKPRHO = ONE - DLKPRH
20118 C* f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
20119 C                     FRCFLL = MAX ( 2.D+00 * FRMRDC / AKPRHO  - ONE,
20120 C     &                              0.05D+00 )
20121 C*                    REDORI = 0.75D+00
20122 C*                    REDORI = ONE
20123 C                     REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20124                   ELSE
20125                      DLKPRH = ZERO
20126                      RDCORE = 1.14D+00 * DBLE(INUC(I))**(ONE/3.D+00)
20127 *  Take out roughly one/half of the skin:
20128                      RDCORE = RDCORE - 0.5D+00
20129                      FRCFLL = RDCORE**3
20130                      PRSKIN = (RDCORE+2.4D+00)**3 - FRCFLL
20131                      PRSKIN = 0.5D+00 * PRSKIN / ( PRSKIN + FRCFLL )
20132                      FRCFLL = ONE - PRSKIN
20133                      FRMRDC = FRCFLL + 0.5D+00 * PRSKIN
20134                      REDORI = ONE / ( FRMRDC )**(2.D+00/3.D+00)
20135                   END IF
20136                   IF ( NNCHIT .GT. 0 ) THEN
20137 C                     IF ( ILCOPT .EQ. 1 ) THEN
20138 C                        SKINRH = ONE - FRCFLL / (DBLE(INUC(I))-ONE)
20139 C                        DO 1220 NCH = 1, 10
20140 C                           ETAETA = ( ONE - SKINRH**INUC(I)
20141 C     &                            - DBLE(INUC(I))* ( ONE - FRCFLL )
20142 C     &                            * ( ONE - SKINRH ) )
20143 C     &                            / ( SKINRH**INUC(I) - DBLE (INUC(I))
20144 C     &                            * ( ONE - FRCFLL) * SKINRH )
20145 C                           SKINRH = SKINRH * ( ONE + ETAETA )
20146 C 1220                   CONTINUE
20147 C                        PRSKIN = SKINRH**(NNCHIT-1)
20148 C                     ELSE IF ( ILCOPT .EQ. 2 ) THEN
20149 C                        PRSKIN = ONE - FRCFLL
20150 C                     END IF
20151                      REDCTN = ZERO
20152                      DO 1230 NCH = 1, NNCHIT
20153                         IF (DT_RNDM(PRFRMI) .LT. PRSKIN) THEN
20154                            PRFRMI = (( ONE - 2.D+00 * DLKPRH )
20155      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
20156                         ELSE
20157                            PRFRMI = ( ONE - 2.D+00 * DLKPRH
20158      &                            * DT_RNDM(PRFRMI))**0.333333333333D+00
20159                         END IF
20160                         REDCTN = REDCTN + PRFRMI**2
20161  1230                CONTINUE
20162                      REDCTN = REDCTN / DBLE (NNCHIT)
20163                   ELSE
20164                      REDCTN = 0.5D+00
20165                   END IF
20166                   EEXC  (I) = EEXC   (I) * REDCTN / REDORI
20167                   AMRCL (I) = AMRCL0 (I) + EEXC (I)
20168                   PRCL(I,4) = SQRT ( PTORCL**2 + AMRCL(I)**2 )
20169                END IF
20170 **
20171                IF (ICASCA.EQ.0) THEN
20172                   EXPNUC(I) = EEXC(I)/MAX(1,INUC(I)-NTOT(I))
20173                   M = MIN(NTOT(I),260)
20174                   EXC(I,M)  = EXC(I,M)+EEXC(I)
20175                   NEXC(I,M) = NEXC(I,M)+1
20176                ENDIF
20177             ENDIF
20178          ELSEIF (NTOT(I).EQ.1) THEN
20179             WRITE(LOUT,1003) I
20180  1003       FORMAT(1X,'FICONF:   warning! NTOT(I)=1? (I=',I3,')')
20181             GOTO 9999
20182          ELSE
20183             AMRCL0(I) = ZERO
20184             AMRCL(I)  = ZERO
20185             EEXC(I)   = ZERO
20186             INORCL    = INORCL+I
20187          ENDIF
20188     7 CONTINUE
20189
20190       PRCLPR(5) = AMRCL(1)
20191       PRCLTA(5) = AMRCL(2)
20192
20193       IF (ICOR.GT.0) THEN
20194          IF (INORCL.EQ.0) THEN
20195 * one or both residual nuclei consist of one nucleon only, transform
20196 * this nucleon on mass shell
20197             DO 9 K=1,4
20198                P1IN(K) = PRCL(1,K)
20199                P2IN(K) = PRCL(2,K)
20200     9       CONTINUE
20201             XM1 = AMRCL(1)
20202             XM2 = AMRCL(2)
20203             CALL DT_MASHEL(P1IN,P2IN,XM1,XM2,P1OUT,P2OUT,IREJ1)
20204             IF (IREJ1.GT.0) THEN
20205                WRITE(LOUT,*) 'ficonf-mashel rejection'
20206                GOTO 9999
20207             ENDIF
20208             DO 10 K=1,4
20209                PRCL(1,K) = P1OUT(K)
20210                PRCL(2,K) = P2OUT(K)
20211                PRCLPR(K) = P1OUT(K)
20212                PRCLTA(K) = P2OUT(K)
20213    10       CONTINUE
20214             PRCLPR(5) = AMRCL(1)
20215             PRCLTA(5) = AMRCL(2)
20216          ELSE
20217             IF (IOULEV(3).GT.0)
20218      &      WRITE(LOUT,1001) NEVHKK,INT(AIF(1)),INT(AIZF(1)),
20219      &                       INT(AIF(2)),INT(AIZF(2)),AMRCL0(1),
20220      &                       AMRCL(1),AMRCL(1)-AMRCL0(1),AMRCL0(2),
20221      &                       AMRCL(2),AMRCL(2)-AMRCL0(2)
20222  1001       FORMAT(1X,'FICONF:   warning! no residual nucleus for',
20223      &             ' correction',/,11X,'at event',I8,
20224      &             ',  nucleon config. 1:',2I4,' 2:',2I4,
20225      &             2(/,11X,3E12.3))
20226             IF (NLOOP.LE.500) THEN
20227                GOTO 9998
20228             ELSE
20229                IREXCI(1) = IREXCI(1)+1
20230             ENDIF
20231          ENDIF
20232       ENDIF
20233
20234 * update counter
20235 C     IF (NRESEV(1).NE.NEVHKK) THEN
20236 C        NRESEV(1) = NEVHKK
20237 C        NRESEV(2) = NRESEV(2)+1
20238 C     ENDIF
20239       NRESEV(2) = NRESEV(2)+1
20240       DO 15 I=1,2
20241          EXCDPM(I)   = EXCDPM(I)+EEXC(I)
20242          EXCDPM(I+2) = EXCDPM(I+2)+(EEXC(I)/MAX(NTOT(I),1))
20243          NRESTO(I) = NRESTO(I)+NTOT(I)
20244          NRESPR(I) = NRESPR(I)+NPRO(I)
20245          NRESNU(I) = NRESNU(I)+NN(I)
20246          NRESBA(I) = NRESBA(I)+NH(I)
20247          NRESPB(I) = NRESPB(I)+NHPOS(I)
20248          NRESCH(I) = NRESCH(I)+NQ(I)
20249    15 CONTINUE
20250
20251 * evaporation
20252       IF (LEVPRT) THEN
20253          DO 13 I=1,2
20254 * initialize evaporation counter
20255             EEXCFI(I) = ZERO
20256             IF ((INUC(I).GT.1).AND.(AIF(I).GT.ONE).AND.
20257      &          (EEXC(I).GT.ZERO)) THEN
20258 * put residual nuclei into DTEVT1
20259                IDRCL = 80000
20260                JMASS = INT( AIF(I))
20261                JCHAR = INT(AIZF(I))
20262 *  the following patch is required to transmit the correct excitation
20263 *   energy to Eventd
20264                IF (ITRSPT.EQ.1) THEN
20265                   IF ((ABS(AMRCL(I)-AMRCL0(I)-EEXC(I)).GT.1.D-04).AND.
20266      &                (IOULEV(3).GT.0))
20267      &               WRITE(LOUT,*)
20268      &                  ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)',
20269      &                              AMRCL(I),AMRCL0(I),EEXC(I)
20270                   PRCL0 = PRCL(I,4)
20271                   PRCL(I,4) =SQRT(AMRCL(I)**2+PRCL(I,1)**2+PRCL(I,2)**2
20272      &                                                    +PRCL(I,3)**2)
20273                   IF (ABS(PRCL0-PRCL(I,4)).GT.0.1D0) THEN
20274                      WRITE(LOUT,*)
20275      &                  ' PRCL(I,4) recalculated :',PRCL0,PRCL(I,4)
20276                   ENDIF
20277                ENDIF
20278                CALL DT_EVTPUT(1000,IDRCL,MO1(I),MO2(I),PRCL(I,1),
20279      &              PRCL(I,2),PRCL(I,3),PRCL(I,4),JMASS,JCHAR,0)
20280 **sr 22.6.97
20281                NOBAM(NHKK) = I
20282 **
20283                DO 14 J=1,4
20284                   VHKK(J,NHKK) = VRCL(I,J)
20285                   WHKK(J,NHKK) = WRCL(I,J)
20286    14          CONTINUE
20287 *  interface to evaporation module - fill final residual nucleus into
20288 *  common FKRESN
20289 *   fill resnuc only if code is not used as event generator in Fluka
20290                IF (ITRSPT.NE.1) THEN
20291                   PXRES  = PRCL(I,1)
20292                   PYRES  = PRCL(I,2)
20293                   PZRES  = PRCL(I,3)
20294                   IBRES  = NPRO(I)+NN(I)+NH(I)
20295                   ICRES  = NPRO(I)+NHPOS(I)
20296                   ANOW   = DBLE(IBRES)
20297                   ZNOW   = DBLE(ICRES)
20298                   PTRES  = SQRT(PXRES**2+PYRES**2+PZRES**2)
20299 *   ground state mass of the residual nucleus (should be equal to AM0T)
20300
20301                   AMNRES = AMRCL0(I)
20302                   AMMRES = AMNAMA ( AMNRES, IBRES, ICRES )
20303
20304 *  common FKFINU
20305                   TV = ZERO
20306 *   kinetic energy of residual nucleus
20307                   TVRECL = PRCL(I,4)-AMRCL(I)
20308 *   excitation energy of residual nucleus
20309                   TVCMS  = EEXC(I)
20310                   PTOLD  = PTRES
20311                   PTRES  = SQRT(ABS(TVRECL*(TVRECL+
20312      &                          2.0D0*(AMMRES+TVCMS))))
20313                   IF (PTOLD.LT.ANGLGB) THEN
20314                      CALL DT_RACO(PXRES,PYRES,PZRES)
20315                      PTOLD = ONE
20316                   ENDIF
20317                   PXRES = PXRES*PTRES/PTOLD
20318                   PYRES = PYRES*PTRES/PTOLD
20319                   PZRES = PZRES*PTRES/PTOLD
20320 * zero counter of secondaries from evaporation
20321                   NP = 0
20322 * evaporation
20323                   WE = ONE
20324
20325                   NPHEAV = 0
20326                   LRNFSS = .FALSE.
20327                   LFRAGM = .FALSE.
20328                   CALL EVEVAP(WE)
20329
20330 * put evaporated particles and residual nuclei to DTEVT1
20331                   MO = NHKK
20332                   CALL DT_EVA2HE(MO,EXCITF,I,IREJ1)
20333                ENDIF
20334                EEXCFI(I) = EXCITF
20335                EXCEVA(I) = EXCEVA(I)+EXCITF
20336             ENDIF
20337    13    CONTINUE
20338       ENDIF
20339
20340       RETURN
20341
20342 C9998 IREXCI(1) = IREXCI(1)+1
20343  9998 IREJ   = IREJ+1
20344  9999 CONTINUE
20345       LRCLPR = .TRUE.
20346       LRCLTA = .TRUE.
20347       IREJ   = IREJ+1
20348       RETURN
20349       END
20350
20351 *$ CREATE DT_EVA2HE.FOR
20352 *COPY DT_EVA2HE
20353 *                                                                      *
20354 *====eva2he============================================================*
20355 *                                                                      *
20356       SUBROUTINE DT_EVA2HE(MO,EEXCF,IRCL,IREJ)
20357
20358 ************************************************************************
20359 * Interface between common's of evaporation module (FKFINU,FKFHVY)     *
20360 * and DTEVT1.                                                          *
20361 *    MO    DTEVT1-index of "mother" (residual) nucleus before evap.    *
20362 *    EEXCF exitation energy of residual nucleus after evaporation      *
20363 *    IRCL  = 1 projectile residual nucleus                             *
20364 *          = 2 target     residual nucleus                             *
20365 * This version dated 19.04.95 is written by S. Roesler.                *
20366 *                                                                      *
20367 * Last change 27.12.2006 by S. Roesler.                                *
20368 ************************************************************************
20369
20370       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20371       SAVE
20372
20373       PARAMETER ( LINP = 10 ,
20374      &            LOUT = 6 ,
20375      &            LDAT = 9 )
20376
20377       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3)
20378
20379 * event history
20380
20381       PARAMETER (NMXHKK=200000)
20382
20383       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
20384      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
20385      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
20386 * Note: DTEVT2 - special use for heavy fragments !
20387 *       (IDRES(I) = mass number, IDXRES(I) = charge)
20388
20389 * extended event history
20390       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
20391      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
20392      &                IHIST(2,NMXHKK)
20393
20394 * particle properties (BAMJET index convention)
20395       CHARACTER*8  ANAME
20396       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20397      &                IICH(210),IIBAR(210),K1(210),K2(210)
20398
20399 * flags for input different options
20400       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
20401       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
20402      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
20403
20404 * statistics: residual nuclei
20405       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
20406      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
20407      &                NINCST(2,4),NINCEV(2),
20408      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
20409      &                NRESPB(2),NRESCH(2),NRESEV(4),
20410      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
20411      &                NEVAFI(2,2)
20412
20413 * treatment of residual nuclei: properties of residual nuclei
20414       COMMON /DTRNU2/ AMRCL0(2),EEXC(2),EEXCFI(2),
20415      &                NTOT(2),NPRO(2),NN(2),NH(2),NHPOS(2),NQ(2),
20416      &                NTOTFI(2),NPROFI(2)
20417
20418 *      INCLUDE '(DIMPAR)'
20419 *     Taken from FLUKA
20420       PARAMETER ( MXXRGN =20000 )
20421       PARAMETER ( MXXMDF =  710 )
20422       PARAMETER ( MXXMDE =  702 )
20423       PARAMETER ( MFSTCK =40000 )
20424       PARAMETER ( MESTCK =  100 )
20425       PARAMETER ( MOSTCK = 2000 )
20426       PARAMETER ( MXPRSN =  100 )
20427       PARAMETER ( MXPDPM =  800 )
20428       PARAMETER ( MXPSCS =30000 )
20429       PARAMETER ( MXGLWN =  300 )
20430       PARAMETER ( MXOUTU =   50 )
20431       PARAMETER ( NALLWP =   64 )
20432       PARAMETER ( NELEMX =   80 )
20433       PARAMETER ( MPDPDX =   18 )
20434       PARAMETER ( MXHTTR =  260 )
20435       PARAMETER ( MXSEAX =   20 )
20436       PARAMETER ( MXHTNC = MXSEAX + 1 )
20437       PARAMETER ( ICOMAX = 2400 )
20438       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
20439       PARAMETER ( NSTBIS =  304 )
20440       PARAMETER ( NQSTIS =   46 )
20441       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
20442       PARAMETER ( MXPABL =  120 )
20443       PARAMETER ( IDMAXP =  450 )
20444       PARAMETER ( IDMXDC = 2000 )
20445       PARAMETER ( MXMCIN =  410 )
20446       PARAMETER ( IHYPMX =    4 )
20447       PARAMETER ( MKBMX1 =   11 )
20448       PARAMETER ( MKBMX2 =   11 )
20449       PARAMETER ( MXIRRD = 2500 )
20450       PARAMETER ( MXTRDC = 1500 )
20451       PARAMETER ( NKTL   =   17 )
20452       PARAMETER ( NBLNMX = 40000000 )
20453
20454 *      INCLUDE '(GENSTK)'
20455 *     Taken from FLUKA
20456       PARAMETER ( MXP = MXPSCS )
20457 *
20458       COMMON / GENSTK /                CXR    (MXPSCS), CYR    (MXPSCS),
20459      &                CZR    (MXPSCS), CXRPOL (MXPSCS), CYRPOL (MXPSCS),
20460      &                CZRPOL (MXPSCS), TKI    (MXPSCS), PLR    (MXPSCS),
20461      &                WEI    (MXPSCS), AGESEC (MXPSCS), TV    , TVCMS  ,
20462      &                TVRECL,  TVHEAV, TVBIND,
20463      &                KPART  (MXPSCS), INFEXT (MXPSCS), NP0   , NP
20464
20465 *      INCLUDE '(RESNUC)'
20466       LOGICAL LRNFSS, LFRAGM
20467       COMMON /RESNUC/  AMNTAR, AMMTAR, AMNZM1, AMMZM1, AMNNM1, AMMNM1,
20468      &                   ANOW,   ZNOW, ANCOLL, ZNCOLL, AMMLFT, AMNLFT,
20469      &                   ERES,  EKRES, AMNRES, AMMRES,  PTRES,  PXRES,
20470      &                  PYRES,  PZRES, PTRES2, ANGRES, ANXRES, ANYRES,
20471      &                 ANZRES, TVESTR, ANESTR, BHYRES (IHYPMX),
20472      &                  KTARP,  KTARN, IGREYP, IGREYN, IPDPM0, IPDPM1,
20473      &                 IPREEH, IPRDEU, IPRTRI, IPR3HE, IPR4HE,  ICRES,
20474      &                  IBRES, ISTRES, ISMRES, IHYRES, IEVAPL, IEVAPH,
20475      &                 IEVPHO, IEVNEU, IEVPRO, IEVDEU, IEVTRI, IEV3HE,
20476      &                 IEV4HE, IDEEXG,  IBTAR, ICHTAR, IBLEFT, ICLEFT,
20477      &                 ICESTR, IBESTR, IOTHER, KHYRES (IHYPMX),
20478      &                 LRNFSS, LFRAGM
20479 *     Taken from FLUKA
20480
20481 *      INCLUDE '(FHEAVY)'
20482 *     Taken from FLUKA
20483       PARAMETER ( MXHEAV = 100 )
20484       PARAMETER ( KXHEAV =  30 )
20485       CHARACTER*8 ANHEAV
20486       COMMON / FHEAVY / CXHEAV (MXHEAV), CYHEAV (MXHEAV),
20487      &                  CZHEAV (MXHEAV), TKHEAV (MXHEAV),
20488      &                  PHEAVY (MXHEAV), WHEAVY (MXHEAV),
20489      &                  AGHEAV (MXHEAV), BHHEAV (IHYPMX,KXHEAV),
20490      &                  AMHEAV (KXHEAV), AMNHEA (KXHEAV),
20491      &                  KHEAVY (MXHEAV), INFHEA (MXHEAV),
20492      &                  ICHEAV (KXHEAV), IBHEAV (KXHEAV),
20493      &                  IMHEAV (KXHEAV), IHHEAV (KXHEAV),
20494      &                  KHHEAV (IHYPMX,KXHEAV), NPHEAV
20495       COMMON / FHEAVC / ANHEAV (KXHEAV)
20496
20497       DIMENSION IPTOKP(39)
20498       DATA IPTOKP / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
20499      & 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 99,
20500      & 100, 101, 97, 102, 98, 103, 109, 115 /
20501
20502       IREJ = 0
20503
20504 * skip if evaporation package is not included
20505       IF (.NOT.LEVAPO) RETURN
20506
20507 * update counter
20508       IF (NRESEV(3).NE.NEVHKK) THEN
20509          NRESEV(3) = NEVHKK
20510          NRESEV(4) = NRESEV(4)+1
20511       ENDIF
20512
20513       IF (LEMCCK)
20514      &   CALL DT_EVTEMC(PHKK(1,MO),PHKK(2,MO),PHKK(3,MO),PHKK(4,MO),1,
20515      &                                                   IDUM,IDUM)
20516 * mass number/charge of residual nucleus before evaporation
20517       IBTOT = IDRES(MO)
20518       IZTOT = IDXRES(MO)
20519
20520 * protons/neutrons/gammas
20521       DO 1 I=1,NP
20522          PX    = CXR(I)*PLR(I)
20523          PY    = CYR(I)*PLR(I)
20524          PZ    = CZR(I)*PLR(I)
20525          ID    = IPTOKP(KPART(I))
20526          IDPDG = IDT_IPDGHA(ID)
20527          AM    = ((PLR(I)+TKI(I))*(PLR(I)-TKI(I)))/
20528      &           (2.0D0*MAX(TKI(I),TINY10))
20529          IF (ABS(AM-AAM(ID)).GT.TINY3) THEN
20530             WRITE(LOUT,1000) ID,AM,AAM(ID)
20531  1000       FORMAT(1X,'EVA2HE:  inconsistent mass of evap. ',
20532      &             'particle',I3,2E10.3)
20533          ENDIF
20534          PE = TKI(I)+AM
20535          CALL DT_EVTPUT(-1,IDPDG,MO,0,PX,PY,PZ,PE,0,0,0)
20536          NOBAM(NHKK) = IRCL
20537          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20538          IBTOT = IBTOT-IIBAR(ID)
20539          IZTOT = IZTOT-IICH(ID)
20540     1 CONTINUE
20541
20542 * heavy fragments
20543       DO 2 I=1,NPHEAV
20544          PX     = CXHEAV(I)*PHEAVY(I)
20545          PY     = CYHEAV(I)*PHEAVY(I)
20546          PZ     = CZHEAV(I)*PHEAVY(I)
20547          IDHEAV = 80000
20548          AM     = ((PHEAVY(I)+TKHEAV(I))*(PHEAVY(I)-TKHEAV(I)))/
20549      &            (2.0D0*MAX(TKHEAV(I),TINY10))
20550          PE     = TKHEAV(I)+AM
20551          CALL DT_EVTPUT(-1,IDHEAV,MO,0,PX,PY,PZ,PE,
20552      &                  IBHEAV(KHEAVY(I)),ICHEAV(KHEAVY(I)),0)
20553          NOBAM(NHKK) = IRCL
20554          IF (LEMCCK) CALL DT_EVTEMC(-PX,-PY,-PZ,-PE,2,IDUM,IDUM)
20555          IBTOT = IBTOT-IBHEAV(KHEAVY(I))
20556          IZTOT = IZTOT-ICHEAV(KHEAVY(I))
20557     2 CONTINUE
20558
20559       IF (IBRES.GT.0) THEN
20560 * residual nucleus after evaporation
20561          IDNUC = 80000
20562          CALL DT_EVTPUT(1001,IDNUC,MO,0,PXRES,PYRES,PZRES,ERES,
20563      &                                        IBRES,ICRES,0)
20564          NOBAM(NHKK) = IRCL
20565       ENDIF
20566       EEXCF = TVCMS
20567       NTOTFI(IRCL) = IBRES
20568       NPROFI(IRCL) = ICRES
20569       IF (LEMCCK) CALL DT_EVTEMC(-PXRES,-PYRES,-PZRES,-ERES,2,IDUM,IDUM)
20570       IBTOT = IBTOT-IBRES
20571       IZTOT = IZTOT-ICRES
20572
20573 * count events with fission
20574       NEVAFI(1,IRCL) = NEVAFI(1,IRCL)+1
20575       IF (LRNFSS) NEVAFI(2,IRCL) = NEVAFI(2,IRCL)+1
20576
20577 * energy-momentum conservation check
20578       IF (LEMCCK) CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,40,IREJ)
20579 C     IF (IREJ.GT.0) THEN
20580 C        CALL DT_EVTOUT(4)
20581 C        WRITE(*,*) EEXC(2),EEXCFI(2),NP,NPHEAV
20582 C     ENDIF
20583 * baryon-number/charge conservation check
20584       IF (IBTOT+IZTOT.NE.0) THEN
20585          WRITE(LOUT,1001) NEVHKK,IBTOT,IZTOT
20586  1001    FORMAT(1X,'EVA2HE:   baryon-number/charge conservation ',
20587      &          'failure at event ',I8,' :  IBTOT,IZTOT = ',2I3)
20588       ENDIF
20589
20590       RETURN
20591       END
20592
20593 *$ CREATE DT_EBIND.FOR
20594 *COPY DT_EBIND
20595 *
20596 *===ebind==============================================================*
20597 *
20598       DOUBLE PRECISION FUNCTION DT_EBIND(IA,IZ)
20599
20600 ************************************************************************
20601 * Binding energy for nuclei.                                           *
20602 * (Shirokov & Yudin, Yad. Fizika, Nauka, Moskva 1972)                  *
20603 *                 IA        mass number                                *
20604 *                 IZ        atomic number                              *
20605 * This version dated 5.5.95   is updated by S. Roesler.                *
20606 ************************************************************************
20607
20608       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20609       SAVE
20610
20611       PARAMETER ( LINP = 10 ,
20612      &            LOUT = 6 ,
20613      &            LDAT = 9 )
20614
20615       PARAMETER (ZERO=0.0D0)
20616
20617       DATA       A1,       A2,        A3,        A4,      A5
20618      &     / 0.01575D0, 0.0178D0, 0.000710D0, 0.0237D0, 0.034D0/
20619
20620       IF ((IA.LE.1).OR.(IZ.EQ.0)) THEN
20621          WRITE(LOUT,'(1X,A,2I5)') 'DT_EBIND IA,IZ set EBIND=0.  ',IA,IZ
20622          DT_EBIND = ZERO
20623          RETURN
20624       ENDIF
20625       AA = IA
20626       DT_EBIND = A1*AA - A2*AA**0.666667D0-A3*IZ*IZ*AA**(-0.333333D0)
20627      &        -A4*(IA-2*IZ)**2/AA
20628       IF (MOD(IA,2).EQ.1) THEN
20629          IA5 = 0
20630       ELSEIF (MOD(IZ,2).EQ.1) THEN
20631          IA5 = 1
20632       ELSE
20633          IA5 = -1
20634       ENDIF
20635       DT_EBIND = DT_EBIND - IA5*A5*AA**(-0.75D0)
20636
20637       RETURN
20638       END
20639
20640 ************************************************************************
20641 *                                                                      *
20642 *  DPMJET 3.0:   cross section routines                                *
20643 *                                                                      *
20644 ************************************************************************
20645 *
20646 *
20647 *     SUBROUTINE DT_SHNDIF
20648 *         diffractive cross sections (all energies)
20649 *     SUBROUTINE DT_PHOXS
20650 *         total and inel. cross sections from PHOJET interpol. tables
20651 *     SUBROUTINE DT_XSHN
20652 *         total and el. cross sections for all energies
20653 *     SUBROUTINE DT_SIHNAB
20654 *         pion 2-nucleon absorption cross sections
20655 *     SUBROUTINE DT_SIGEMU
20656 *         cross section for target "compounds"
20657 *     SUBROUTINE DT_SIGGA
20658 *         photon nucleus cross sections
20659 *     SUBROUTINE DT_SIGGAT
20660 *         photon nucleus cross sections from tables
20661 *     SUBROUTINE DT_SANO
20662 *         anomalous hard photon-nucleon cross sections from tables
20663 *     SUBROUTINE DT_SIGGP
20664 *         photon nucleon cross sections
20665 *     SUBROUTINE DT_SIGVEL
20666 *         quasi-elastic vector meson prod. cross sections
20667 *     DOUBLE PRECISION FUNCTION DT_SIGVP
20668 *         sigma_VN(tilde)
20669 *     DOUBLE PRECISION FUNCTION DT_RRM2
20670 *     DOUBLE PRECISION FUNCTION DT_RM2
20671 *     DOUBLE PRECISION FUNCTION DT_SAM2
20672 *     SUBROUTINE DT_CKMT
20673 *     SUBROUTINE DT_CKMTX
20674 *     SUBROUTINE DT_PDF0
20675 *     SUBROUTINE DT_CKMTQ0
20676 *     SUBROUTINE DT_CKMTDE
20677 *     SUBROUTINE DT_CKMTPR
20678 *     FUNCTION DT_CKMTFF
20679 *
20680 *     SUBROUTINE DT_FLUINI
20681 *         total nucleon cross section fluctuation treatment
20682 *
20683 *     SUBROUTINE DT_SIGTBL
20684 *         pre-tabulation of low-energy elastic x-sec. using SIHNEL
20685 *     SUBROUTINE DT_XSTABL
20686 *         service routines
20687 *
20688 *
20689 *$ CREATE DT_SHNDIF.FOR
20690 *COPY DT_SHNDIF
20691 *
20692 *===shndif===============================================================*
20693 *
20694       SUBROUTINE DT_SHNDIF(ECM,KPROJ,KTARG,SIGDIF,SIGDIH)
20695
20696 **********************************************************************
20697 *   Single diffractive hadron-nucleon cross sections                 *
20698 *                                              S.Roesler 14/1/93     *
20699 *                                                                    *
20700 *   The cross sections are calculated from extrapolated single       *
20701 *   diffractive antiproton-proton cross sections (DTUJET92) using    *
20702 *   scaling relations between total and single diffractive cross     *
20703 *   sections.                                                        *
20704 **********************************************************************
20705
20706       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20707       SAVE
20708       PARAMETER (ZERO=0.0D0)
20709
20710 * particle properties (BAMJET index convention)
20711       CHARACTER*8  ANAME
20712       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20713      &                IICH(210),IIBAR(210),K1(210),K2(210)
20714 *
20715       CSD1   =   4.201483727D0
20716       CSD4   = -0.4763103556D-02
20717       CSD5   =  0.4324148297D0
20718 *
20719       CHMSD1 =  0.8519297242D0
20720       CHMSD4 = -0.1443076599D-01
20721       CHMSD5 =  0.4014954567D0
20722 *
20723       EPN = (ECM**2 -AAM(KPROJ)**2 -AAM(KTARG)**2)/(2.0D0*AAM(KTARG))
20724       PPN = SQRT((EPN-AAM(KPROJ))*(EPN+AAM(KPROJ)))
20725 *
20726       SDIAPP = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20727       SHMSD  = CHMSD1+CHMSD4*LOG(PPN)**2+CHMSD5*LOG(PPN)
20728       FRAC   = SHMSD/SDIAPP
20729 *
20730       GOTO( 10, 20,999,999,999,999,999, 10, 20,999,
20731      &     999, 20, 20, 20, 20, 20, 10, 20, 20, 10,
20732      &      10, 10, 20, 20, 20) KPROJ
20733 *
20734    10 CONTINUE
20735 *---------------------------- p - p , n - p , sigma0+- - p ,
20736 *                             Lambda - p
20737       CSD1   =  6.004476070D0
20738       CSD4   = -0.1257784606D-03
20739       CSD5   =  0.2447335720D0
20740       SIGDIF = CSD1+CSD4*LOG(PPN)**2+CSD5*LOG(PPN)
20741       SIGDIH = FRAC*SIGDIF
20742       RETURN
20743 *
20744    20 CONTINUE
20745 *
20746       KPSCAL = 2
20747       KTSCAL = 1
20748 C     F      = SDIAPP/DT_SHNTOT(KPSCAL,KTSCAL,ECM,ZERO)
20749       DUMZER = ZERO
20750       CALL DT_XSHN(KPSCAL,KTSCAL,DUMZER,ECM,SIGTO,SIGEL)
20751       F      = SDIAPP/SIGTO
20752       KT     = 1
20753 C     SIGDIF = DT_SHNTOT(KPROJ,KT,ECM,ZERO)*F
20754       CALL DT_XSHN(KPROJ,KT,DUMZER,ECM,SIGTO,SIGEL)
20755       SIGDIF = SIGTO*F
20756       SIGDIH = FRAC*SIGDIF
20757       RETURN
20758 *
20759   999 CONTINUE
20760 *-------------------------- leptons..
20761       SIGDIF = 1.D-10
20762       SIGDIH = 1.D-10
20763       RETURN
20764       END
20765
20766 *$ CREATE DT_PHOXS.FOR
20767 *COPY DT_PHOXS
20768 *
20769 *===phoxs================================================================*
20770 *
20771       SUBROUTINE DT_PHOXS(KPROJ,KTARG,ECM,PLAB,STOT,SINE,SDIF1,BEL,MODE)
20772
20773 ************************************************************************
20774 * Total/inelastic proton-nucleon cross sections taken from PHOJET-     *
20775 * interpolation tables.                                                *
20776 * This version dated 05.11.97 is written by S. Roesler                 *
20777 ************************************************************************
20778
20779       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20780       SAVE
20781
20782       PARAMETER ( LINP = 10 ,
20783      &            LOUT = 6 ,
20784      &            LDAT = 9 )
20785
20786       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
20787       PARAMETER (TWOPI  = 6.283185307179586454D+00,
20788      &           PI     = TWOPI/TWO,
20789      &           GEV2MB = 0.38938D0)
20790
20791       LOGICAL LFIRST
20792       DATA LFIRST /.TRUE./
20793
20794 * nucleon-nucleon event-generator
20795       CHARACTER*8 CMODEL
20796       LOGICAL LPHOIN
20797       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20798
20799 * particle properties (BAMJET index convention)
20800       CHARACTER*8  ANAME
20801       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20802      &                IICH(210),IIBAR(210),K1(210),K2(210)
20803
20804 **PHOJET105a
20805 C     PARAMETER (IEETAB=10)
20806 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20807 **PHOJET110
20808
20809 C  energy-interpolation table
20810       INTEGER IEETA2
20811       PARAMETER ( IEETA2 = 20 )
20812       INTEGER ISIMAX
20813       DOUBLE PRECISION SIGTAB,SIGECM
20814       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20815 **
20816
20817       IF ((MCGENE.NE.2).AND.(MODE.NE.1)) THEN
20818          WRITE(LOUT,*) MCGENE
20819  1000    FORMAT(1X,'PHOXS: warning! PHOJET not initialized (',I2,')')
20820          STOP
20821       ENDIF
20822
20823       IF (ECM.LE.ZERO) THEN
20824          EPN = SQRT(AAM(KPROJ)**2+PLAB**2)
20825          ECM = SQRT(AAM(KPROJ)**2+AAM(KTARG)**2+2.0D0*EPN*AAM(KTARG))
20826       ENDIF
20827
20828       IF (MODE.EQ.1) THEN
20829 * DL
20830          DELDL = 0.0808D0
20831          EPSDL = -0.4525D0
20832          S     = ECM*ECM
20833          STOT  = 21.7D0*S**DELDL+56.08D0*S**EPSDL
20834          ALPHAP= 0.25D0
20835          BEL   = 8.5D0+2.D0*ALPHAP*LOG(S)
20836          SIGEL = STOT**2/(16.D0*PI*BEL*GEV2MB)
20837          SINE  = STOT-SIGEL
20838          SDIF1 = ZERO
20839       ELSE
20840 * Phojet
20841          IP = 1
20842          IF(ECM.LE.SIGECM(IP,1)) THEN
20843            I1 = 1
20844            I2 = 1
20845          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
20846            DO 1 I=2,ISIMAX
20847               IF (ECM.LE.SIGECM(IP,I)) GOTO 2
20848     1      CONTINUE
20849     2      CONTINUE
20850            I1 = I-1
20851            I2 = I
20852          ELSE
20853            IF (LFIRST) THEN
20854               WRITE(LOUT,'(/1X,A,2E12.3)')
20855      &          'PHOXS: warning! energy above initialization limit (',
20856      &          ECM,SIGECM(IP,ISIMAX)
20857              LFIRST = .FALSE.
20858            ENDIF
20859            I1 = ISIMAX
20860            I2 = ISIMAX
20861          ENDIF
20862          FAC2 = ZERO
20863          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
20864      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
20865          FAC1  = ONE-FAC2
20866          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
20867          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
20868          SDIF1 = FAC2*(SIGTAB(IP,30,I2)+SIGTAB(IP,32,I2))+
20869      &           FAC1*(SIGTAB(IP,30,I1)+SIGTAB(IP,32,I1))
20870          BEL   = FAC2*SIGTAB(IP,39,I2)+FAC1*SIGTAB(IP,39,I1)
20871       ENDIF
20872
20873       RETURN
20874       END
20875
20876 *$ CREATE DT_XSHN.FOR
20877 *COPY DT_XSHN
20878 *
20879 *===xshn===============================================================*
20880 *
20881       SUBROUTINE DT_XSHN(IP,IT,PL,ECM,STOT,SELA)
20882
20883 ************************************************************************
20884 * Total and elastic hadron-nucleon cross section.                      *
20885 * Below 500GeV cross sections are based on the '98 data compilation    *
20886 * of the PDG. At higher energies PHOJET results are used (patched to   *
20887 * the low energy data at 500GeV).                                      *
20888 *     IP      projectile index (BAMJET numbering scheme)               *
20889 *             (should be in the range 1..25)                           *
20890 *     IT      target index (BAMJET numbering scheme)                   *
20891 *             (1 = proton, 8 = neutron)                                *
20892 *     PL      laboratory momentum                                      *
20893 *     ECM     cm. energy (ignored if PL>0)                             *
20894 *     STOT    total cross section                                      *
20895 *     SELA    elastic cross section                                    *
20896 * Last change: 24.4.99 by S. Roesler                                   *
20897 ************************************************************************
20898
20899       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
20900       SAVE
20901
20902       PARAMETER ( LINP = 10 ,
20903      &            LOUT = 6 ,
20904      &            LDAT = 9 )
20905
20906       PARAMETER (ZERO=0.0D0,ONE=1.0D0)
20907
20908       PARAMETER (NPOIN1 = 54, NPOIN2 = 8,
20909      &           PLABLO = 0.1D0, PTHRE = 5.0D0, PLABHI = 500.0D0)
20910       PARAMETER (NPOINT = NPOIN1+NPOIN2+1)
20911
20912       LOGICAL LFIRST
20913
20914 * particle properties (BAMJET index convention)
20915       CHARACTER*8  ANAME
20916       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
20917      &                IICH(210),IIBAR(210),K1(210),K2(210)
20918
20919 * nucleon-nucleon event-generator
20920       CHARACTER*8 CMODEL
20921       LOGICAL LPHOIN
20922       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
20923 **PHOJET105a
20924 C     PARAMETER (IEETAB=10)
20925 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
20926 **PHOJET110
20927
20928 C  energy-interpolation table
20929       INTEGER IEETA2
20930       PARAMETER ( IEETA2 = 20 )
20931       INTEGER ISIMAX
20932       DOUBLE PRECISION SIGTAB,SIGECM
20933       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
20934
20935       DIMENSION APL(NPOINT),ASIGTO(10,NPOINT),ASIGEL(10,NPOINT)
20936       DIMENSION IDXDAT(25,2)
20937 *
20938       DATA APL /
20939      &-1.000,-0.969,-0.937,-0.906,-0.874,-0.843,-0.811,-0.780,-0.748,
20940      &-0.717,-0.685,-0.654,-0.622,-0.591,-0.560,-0.528,-0.497,-0.465,
20941      &-0.434,-0.402,-0.371,-0.339,-0.308,-0.276,-0.245,-0.213,-0.182,
20942      &-0.151,-0.119,-0.088,-0.056,-0.025, 0.007, 0.038, 0.070, 0.101,
20943      & 0.133, 0.164, 0.196, 0.227, 0.258, 0.290, 0.321, 0.353, 0.384,
20944      & 0.416, 0.447, 0.479, 0.510, 0.542, 0.573, 0.605, 0.636, 0.668,
20945      & 0.699, 0.949, 1.199, 1.449, 1.699, 1.949, 2.199, 2.449, 2.699/
20946 *
20947 * total cross sections:
20948 * p p
20949       DATA (ASIGTO(1,K),K=1,NPOINT) /
20950      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
20951      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
20952      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.375, 1.363, 1.356, 1.352,
20953      & 1.350, 1.351, 1.359, 1.381, 1.410, 1.444, 1.487, 1.544, 1.596,
20954      & 1.650, 1.672, 1.676, 1.677, 1.677, 1.675, 1.675, 1.669, 1.664,
20955      & 1.658, 1.653, 1.645, 1.640, 1.634, 1.630, 1.625, 1.620, 1.617,
20956      & 1.614, 1.602, 1.594, 1.589, 1.581, 1.583, 1.588, 1.596, 1.603/
20957 * pbar p
20958       DATA (ASIGTO(2,K),K=1,NPOINT) /
20959      & 2.778, 2.759, 2.739, 2.718, 2.697, 2.675, 2.651, 2.626, 2.598,
20960      & 2.569, 2.537, 2.502, 2.471, 2.443, 2.420, 2.389, 2.361, 2.329,
20961      & 2.313, 2.304, 2.268, 2.244, 2.222, 2.212, 2.178, 2.162, 2.151,
20962      & 2.132, 2.109, 2.097, 2.089, 2.078, 2.063, 2.049, 2.035, 2.024,
20963      & 2.014, 2.004, 1.993, 1.981, 1.970, 1.958, 1.946, 1.933, 1.921,
20964      & 1.909, 1.894, 1.885, 1.871, 1.854, 1.836, 1.825, 1.816, 1.802,
20965      & 1.790, 1.744, 1.694, 1.663, 1.642, 1.614, 1.623, 1.623, 1.630/
20966 * n p
20967       DATA (ASIGTO(3,K),K=1,NPOINT) /
20968      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
20969      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
20970      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
20971      & 1.547, 1.534, 1.526, 1.522, 1.520, 1.525, 1.536, 1.550, 1.566,
20972      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
20973      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
20974      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
20975 * pi+ p
20976       DATA (ASIGTO(4,K),K=1,NPOINT) /
20977      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
20978      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
20979      & 2.001, 1.875, 1.801, 1.665, 1.609, 1.484, 1.412, 1.334, 1.195,
20980      & 1.160, 1.166, 1.208, 1.309, 1.356, 1.394, 1.406, 1.419, 1.473,
20981      & 1.540, 1.596, 1.570, 1.533, 1.516, 1.484, 1.471, 1.478, 1.492,
20982      & 1.497, 1.491, 1.479, 1.465, 1.453, 1.449, 1.450, 1.444, 1.428,
20983      & 1.422, 1.406, 1.384, 1.369, 1.364, 1.369, 1.374, 1.388, 1.395/
20984 * pi- p
20985       DATA (ASIGTO(5,K),K=1,NPOINT) /
20986      & 0.458, 0.540, 0.626, 0.718, 0.819, 0.933, 1.063, 1.208, 1.226,
20987      & 1.436, 1.470, 1.594, 1.708, 1.786, 1.852, 1.836, 1.763, 1.679,
20988      & 1.590, 1.492, 1.445, 1.426, 1.423, 1.433, 1.473, 1.506, 1.547,
20989      & 1.660, 1.671, 1.545, 1.591, 1.687, 1.808, 1.656, 1.582, 1.543,
20990      & 1.562, 1.560, 1.537, 1.540, 1.549, 1.557, 1.557, 1.551, 1.535,
20991      & 1.527, 1.511, 1.510, 1.507, 1.500, 1.491, 1.483, 1.478, 1.468,
20992      & 1.463, 1.435, 1.408, 1.394, 1.384, 1.380, 1.383, 1.393, 1.411/
20993 * K+ p
20994       DATA (ASIGTO(6,K),K=1,NPOINT) /
20995      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
20996      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097,
20997      & 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.097, 1.096, 1.095,
20998      & 1.098, 1.105, 1.111, 1.139, 1.169, 1.209, 1.248, 1.259, 1.268,
20999      & 1.262, 1.257, 1.254, 1.252, 1.250, 1.249, 1.246, 1.244, 1.244,
21000      & 1.243, 1.240, 1.238, 1.237, 1.236, 1.235, 1.235, 1.236, 1.236,
21001      & 1.236, 1.233, 1.238, 1.248, 1.257, 1.272, 1.292, 1.311, 1.336/
21002 * K- p
21003       DATA (ASIGTO(7,K),K=1,NPOINT) /
21004      & 2.003, 2.002, 2.001, 2.000, 1.999, 1.998, 1.998, 1.997, 1.997,
21005      & 1.996, 1.995, 1.993, 1.990, 1.992, 1.974, 1.912, 1.865, 1.847,
21006      & 1.896, 1.950, 1.827, 1.681, 1.637, 1.616, 1.589, 1.545, 1.543,
21007      & 1.532, 1.603, 1.604, 1.616, 1.658, 1.700, 1.658, 1.595, 1.508,
21008      & 1.493, 1.514, 1.531, 1.523, 1.501, 1.479, 1.474, 1.467, 1.463,
21009      & 1.450, 1.444, 1.435, 1.426, 1.424, 1.423, 1.415, 1.401, 1.396,
21010      & 1.384, 1.364, 1.330, 1.313, 1.310, 1.309, 1.317, 1.329, 1.338/
21011 * K+ n
21012       DATA (ASIGTO(8,K),K=1,NPOINT) /
21013      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21014      & 0.631, 0.675, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21015      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.102, 1.125, 1.147,
21016      & 1.168, 1.187, 1.205, 1.224, 1.248, 1.279, 1.315, 1.324, 1.301,
21017      & 1.285, 1.279, 1.274, 1.273, 1.272, 1.271, 1.267, 1.263, 1.261,
21018      & 1.259, 1.256, 1.252, 1.247, 1.244, 1.241, 1.240, 1.240, 1.240,
21019      & 1.241, 1.243, 1.245, 1.253, 1.265, 1.275, 1.293, 1.314, 1.342/
21020 * K- n
21021       DATA (ASIGTO(9,K),K=1,NPOINT) /
21022      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778, 1.778,
21023      & 1.778, 1.778, 1.778, 1.778, 1.778, 1.779, 1.779, 1.778, 1.773,
21024      & 1.765, 1.746, 1.703, 1.646, 1.561, 1.488, 1.454, 1.437, 1.437,
21025      & 1.458, 1.505, 1.561, 1.588, 1.593, 1.581, 1.551, 1.500, 1.454,
21026      & 1.427, 1.408, 1.390, 1.372, 1.361, 1.356, 1.351, 1.347, 1.343,
21027      & 1.341, 1.340, 1.338, 1.337, 1.335, 1.334, 1.332, 1.331, 1.330,
21028      & 1.330, 1.313, 1.303, 1.288, 1.288, 1.297, 1.305, 1.320, 1.342/
21029 * Lambda p
21030       DATA (ASIGTO(10,K),K=1,NPOINT) /
21031      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21032      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.629,
21033      & 1.599, 1.576, 1.558, 1.543, 1.530, 1.520, 1.512, 1.505, 1.499,
21034      & 1.495, 1.495, 1.497, 1.504, 1.514, 1.525, 1.536, 1.550, 1.567,
21035      & 1.578, 1.580, 1.581, 1.584, 1.590, 1.598, 1.605, 1.608, 1.609,
21036      & 1.608, 1.608, 1.608, 1.608, 1.608, 1.607, 1.606, 1.606, 1.605,
21037      & 1.606, 1.599, 1.588, 1.587, 1.586, 1.589, 1.592, 1.597, 1.600/
21038 *
21039 * elastic cross sections:
21040 * p p
21041       DATA (ASIGEL(1,K),K=1,NPOINT) /
21042      & 2.837, 2.760, 2.686, 2.614, 2.543, 2.472, 2.401, 2.329, 2.255,
21043      & 2.180, 2.103, 2.030, 1.968, 1.919, 1.861, 1.775, 1.698, 1.646,
21044      & 1.577, 1.518, 1.462, 1.420, 1.393, 1.374, 1.360, 1.353, 1.350,
21045      & 1.351, 1.356, 1.362, 1.369, 1.376, 1.384, 1.385, 1.399, 1.397,
21046      & 1.389, 1.385, 1.379, 1.366, 1.358, 1.344, 1.320, 1.294, 1.275,
21047      & 1.260, 1.248, 1.235, 1.219, 1.199, 1.172, 1.144, 1.126, 1.115,
21048      & 1.104, 1.013, 0.962, 0.905, 0.869, 0.845, 0.846, 0.850, 0.868/
21049 * pbar p
21050       DATA (ASIGEL(2,K),K=1,NPOINT) /
21051      & 1.987, 1.985, 1.983, 1.980, 1.978, 1.975, 1.971, 1.968, 1.963,
21052      & 1.958, 1.951, 1.944, 1.935, 1.925, 1.914, 1.902, 1.889, 1.875,
21053      & 1.859, 1.845, 1.834, 1.817, 1.792, 1.769, 1.754, 1.738, 1.720,
21054      & 1.702, 1.688, 1.676, 1.667, 1.659, 1.652, 1.645, 1.640, 1.636,
21055      & 1.620, 1.591, 1.562, 1.546, 1.540, 1.524, 1.496, 1.475, 1.457,
21056      & 1.429, 1.402, 1.373, 1.344, 1.330, 1.306, 1.294, 1.265, 1.228,
21057      & 1.204, 1.086, 0.977, 0.933, 0.914, 0.850, 0.862, 0.848, 0.845/
21058 * n p
21059       DATA (ASIGEL(3,K),K=1,NPOINT) /
21060      & 3.192, 3.145, 3.097, 3.047, 2.995, 2.940, 2.883, 2.824, 2.763,
21061      & 2.700, 2.634, 2.565, 2.494, 2.420, 2.344, 2.269, 2.196, 2.115,
21062      & 2.048, 1.964, 1.906, 1.842, 1.779, 1.719, 1.656, 1.604, 1.569,
21063      & 1.544, 1.527, 1.514, 1.504, 1.495, 1.486, 1.476, 1.466, 1.454,
21064      & 1.440, 1.425, 1.409, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21065      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21066      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21067 * pi+ p
21068       DATA (ASIGEL(4,K),K=1,NPOINT) /
21069      & 0.643, 0.786, 0.929, 1.074, 1.199, 1.272, 1.340, 1.484, 1.610,
21070      & 1.750, 1.881, 2.014, 2.178, 2.244, 2.301, 2.309, 2.219, 2.118,
21071      & 2.001, 1.875, 1.801, 1.664, 1.610, 1.479, 1.423, 1.299, 1.166,
21072      & 1.097, 1.020, 0.958, 0.914, 1.013, 1.088, 1.153, 1.167, 1.235,
21073      & 1.240, 1.237, 1.202, 1.135, 1.090, 1.026, 0.975, 0.941, 0.904,
21074      & 0.894, 0.884, 0.862, 0.850, 0.845, 0.827, 0.805, 0.789, 0.776,
21075      & 0.763, 0.686, 0.626, 0.562, 0.505, 0.518, 0.525, 0.528, 0.528/
21076 * pi- p
21077       DATA (ASIGEL(5,K),K=1,NPOINT) /
21078      & 0.266, 0.278, 0.294, 0.320, 0.360, 0.419, 0.503, 0.608, 0.727,
21079      & 0.850, 0.968, 1.071, 1.167, 1.305, 1.369, 1.404, 1.446, 1.217,
21080      & 1.112, 1.071, 1.014, 1.002, 0.996, 1.008, 1.070, 1.126, 1.209,
21081      & 1.300, 1.281, 1.188, 1.156, 1.341, 1.423, 1.314, 1.171, 1.140,
21082      & 1.106, 1.071, 1.011, 1.037, 1.026, 1.024, 0.988, 0.953, 0.895,
21083      & 0.894, 0.880, 0.871, 0.864, 0.853, 0.837, 0.820, 0.809, 0.800,
21084      & 0.782, 0.674, 0.612, 0.530, 0.521, 0.528, 0.524, 0.542, 0.569/
21085 * K+ p
21086       DATA (ASIGEL(6,K),K=1,NPOINT) /
21087      & 1.064, 1.065, 1.065, 1.066, 1.066, 1.066, 1.066, 1.066, 1.066,
21088      & 1.065, 1.064, 1.063, 1.062, 1.062, 1.062, 1.064, 1.066, 1.070,
21089      & 1.076, 1.082, 1.088, 1.096, 1.103, 1.104, 1.104, 1.102, 1.093,
21090      & 1.087, 1.084, 1.079, 1.075, 1.067, 1.058, 1.040, 1.029, 1.012,
21091      & 1.003, 0.985, 0.935, 0.909, 0.880, 0.846, 0.790, 0.771, 0.759,
21092      & 0.743, 0.718, 0.681, 0.666, 0.645, 0.622, 0.606, 0.594, 0.584,
21093      & 0.575, 0.513, 0.453, 0.403, 0.356, 0.365, 0.389, 0.430, 0.477/
21094 * K- p
21095       DATA (ASIGEL(7,K),K=1,NPOINT) /
21096      & 1.941, 1.936, 1.931, 1.926, 1.919, 1.912, 1.903, 1.892, 1.878,
21097      & 1.863, 1.844, 1.821, 1.791, 1.755, 1.713, 1.666, 1.615, 1.561,
21098      & 1.533, 1.531, 1.518, 1.511, 1.452, 1.339, 1.265, 1.233, 1.188,
21099      & 1.184, 1.236, 1.316, 1.333, 1.336, 1.333, 1.277, 1.216, 1.077,
21100      & 1.018, 0.912, 0.926, 0.920, 0.910, 0.894, 0.830, 0.825, 0.800,
21101      & 0.788, 0.747, 0.703, 0.707, 0.689, 0.643, 0.633, 0.635, 0.618,
21102      & 0.584, 0.579, 0.461, 0.403, 0.405, 0.399, 0.408, 0.418, 0.413/
21103 * K+ n
21104       DATA (ASIGEL(8,K),K=1,NPOINT) /
21105      & 0.176, 0.229, 0.282, 0.334, 0.386, 0.437, 0.487, 0.536, 0.584,
21106      & 0.631, 0.676, 0.719, 0.760, 0.799, 0.835, 0.870, 0.901, 0.931,
21107      & 0.958, 0.984, 1.008, 1.032, 1.056, 1.079, 1.103, 1.126, 1.148,
21108      & 1.168, 1.187, 1.205, 1.223, 1.248, 1.282, 1.269, 1.185, 1.111,
21109      & 1.063, 1.031, 0.998, 0.964, 0.928, 0.889, 0.849, 0.814, 0.785,
21110      & 0.760, 0.738, 0.720, 0.703, 0.688, 0.674, 0.660, 0.648, 0.635,
21111      & 0.624, 0.536, 0.473, 0.442, 0.428, 0.428, 0.436, 0.453, 0.477/
21112 * K- n
21113       DATA (ASIGEL(9,K),K=1,NPOINT) /
21114      & 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613, 1.613,
21115      & 1.613, 1.613, 1.613, 1.612, 1.613, 1.614, 1.614, 1.612, 1.606,
21116      & 1.593, 1.564, 1.498, 1.402, 1.240, 1.071, 0.977, 0.922, 0.914,
21117      & 0.961, 1.077, 1.214, 1.271, 1.290, 1.281, 1.217, 1.096, 0.979,
21118      & 0.896, 0.822, 0.736, 0.655, 0.608, 0.591, 0.580, 0.569, 0.559,
21119      & 0.550, 0.540, 0.531, 0.522, 0.514, 0.507, 0.500, 0.494, 0.489,
21120      & 0.485, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477, 0.477/
21121 * Lambda p
21122       DATA (ASIGEL(10,K),K=1,NPOINT) /
21123      & 2.648, 2.598, 2.548, 2.498, 2.446, 2.394, 2.340, 2.283, 2.224,
21124      & 2.160, 2.091, 2.015, 1.936, 1.858, 1.785, 1.720, 1.669, 1.630,
21125      & 1.600, 1.577, 1.558, 1.542, 1.528, 1.518, 1.510, 1.505, 1.502,
21126      & 1.501, 1.500, 1.499, 1.496, 1.491, 1.485, 1.477, 1.466, 1.454,
21127      & 1.440, 1.425, 1.408, 1.392, 1.375, 1.358, 1.340, 1.322, 1.304,
21128      & 1.285, 1.267, 1.250, 1.234, 1.219, 1.202, 1.181, 1.158, 1.136,
21129      & 1.116, 0.727,-2.128, -10.0, -10.0, -10.0, -10.0, -10.0, -10.0/
21130
21131       DATA (IDXDAT(K,1),K=1,25) /
21132      &  1, 2, 0, 0, 0, 0, 0, 3, 2, 0, 0,67, 4, 5, 6, 7,10, 2,67, 3,
21133      &  1, 3,45, 8, 9/
21134       DATA (IDXDAT(K,2),K=1,25) /
21135      &  3, 2, 0, 0, 0, 0, 0, 1, 2, 0, 0,89, 5, 4, 8, 9, 1, 2,89, 1,
21136      &  3, 1,45, 6, 7/
21137
21138       DATA LFIRST /.TRUE./
21139
21140       IF (LFIRST) THEN
21141          APLABL = LOG10(PLABLO)
21142          APLABH = LOG10(PLABHI)
21143          APTHRE = LOG10(PTHRE)
21144          ADP1   = (APTHRE-APLABL)/DBLE(NPOIN1)
21145          ADP2   = (APLABH-APTHRE)/DBLE(NPOIN2)
21146          DUM0   = ZERO
21147          PHOPLA = PLABHI
21148          PHOELA = SQRT(AAM(1)**2+PHOPLA**2)
21149          ECMS   = SQRT(2.0D0*AAM(1)**2+2.0D0*AAM(1)*PHOELA)
21150          IF (MCGENE.EQ.2) THEN
21151             IF (ECMS.LE.SIGECM(1,ISIMAX)) THEN
21152                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,0)
21153             ELSE
21154                CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21155             ENDIF
21156          ELSE
21157             CALL DT_PHOXS(1,1,DUM0,PHOPLA,PHOSTO,PHOSIN,DUM1,DUM2,1)
21158          ENDIF
21159          PHOSEL = PHOSTO-PHOSIN
21160          APHOST = LOG10(PHOSTO)
21161          APHOSE = LOG10(PHOSEL)
21162          LFIRST = .FALSE.
21163       ENDIF
21164       STOT = ZERO
21165       SELA = ZERO
21166       PLAB = PL
21167       ECMS = ECM
21168       IF ( (IP.LT.1).OR.((IT.NE.1).AND.(IT.NE.8)) ) THEN
21169          WRITE(LOUT,1000) IP,IT
21170  1000    FORMAT(1X,'DT_XSHN: cross sections not implemented for ',
21171      &          'proj/target',2I4)
21172          STOP
21173       ENDIF
21174
21175       IF ((PLAB.LE.ZERO).AND.(ECMS.GT.ZERO)) THEN
21176          ELAB = (ECMS**2-AAM(IP)**2-AAM(IT)**2)/(2.0D0*AAM(IT))
21177          PLAB = SQRT((ELAB-AAM(IP))*(ELAB+AAM(IP)))
21178       ELSEIF ((PLAB.LE.ZERO).AND.(ECMS.LE.ZERO)) THEN
21179          WRITE(LOUT,1001) PLAB,ECMS
21180  1001    FORMAT(1X,'DT_XSHN: invalid momentum/cm-energy ',2E15.5)
21181          STOP
21182       ENDIF
21183
21184 * index of spectrum
21185       IDXP = IP
21186       IF (IP.GT.25) THEN
21187          IF (AAM(IP).GT.ZERO) THEN
21188             IF (ABS(IIBAR(IP)).GT.0) THEN
21189                IDXP = 1
21190             ELSE
21191                IDXP = 13
21192             ENDIF
21193          ELSE
21194             IDXP = 7
21195          ENDIF
21196       ENDIF
21197       IDXT = 1
21198       IF (IT.EQ.8) IDXT = 2
21199       IDXS = IDXDAT(IDXP,IDXT)
21200       IF (IDXS.EQ.0) RETURN
21201
21202 * compute momentum bin indices
21203       IF (PLAB.LT.PLABLO) THEN
21204          IDX0 = 1
21205          IDX1 = 1
21206       ELSEIF (PLAB.GE.PLABHI) THEN
21207          IDX0 = NPOINT
21208          IDX1 = NPOINT
21209       ELSE
21210          APLAB = LOG10(PLAB)
21211          IF ((PLAB.GE.PLABLO).AND.(PLAB.LT.PTHRE )) THEN
21212             IDX0 = INT((APLAB-APLABL)/ADP1)+1
21213          ELSEIF ((PLAB.GE.PTHRE ).AND.(PLAB.LT.PLABHI)) THEN
21214             IDX0 = INT((APLAB-APTHRE)/ADP2)+NPOIN1+1
21215          ENDIF
21216          IDX1 = IDX0+1
21217       ENDIF
21218
21219 * interpolate cross section
21220       IF (IDXS.GT.10) THEN
21221          IDXS1 = IDXS/10
21222          IDXS2 = IDXS-10*IDXS1
21223          IF (IDX0.EQ.IDX1) THEN
21224             IF (IDX0.EQ.1) THEN
21225                ASTOT = 0.5D0*(ASIGTO(IDXS1,IDX0)+ASIGTO(IDXS2,IDX0))
21226                ASELA = 0.5D0*(ASIGEL(IDXS1,IDX0)+ASIGEL(IDXS2,IDX0))
21227             ELSE
21228                DUM0   = ZERO
21229                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21230                PHOSEL = PHOSTO-PHOSIN
21231                ASTOT1 = ASIGTO(IDXS1,NPOINT)-APHOST+LOG10(PHOSTO)
21232                ASELA1 = ASIGEL(IDXS1,NPOINT)-APHOSE+LOG10(PHOSEL)
21233                ASTOT2 = ASIGTO(IDXS2,NPOINT)-APHOST+LOG10(PHOSTO)
21234                ASELA2 = ASIGEL(IDXS2,NPOINT)-APHOSE+LOG10(PHOSEL)
21235                ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21236                ASELA  = 0.5D0*(ASELA1+ASELA2)
21237             ENDIF
21238          ELSE
21239             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21240             ASTOT1 = ASIGTO(IDXS1,IDX0)+
21241      &               FAC*(ASIGTO(IDXS1,IDX1)-ASIGTO(IDXS1,IDX0))
21242             ASTOT2 = ASIGTO(IDXS2,IDX0)+
21243      &               FAC*(ASIGTO(IDXS2,IDX1)-ASIGTO(IDXS2,IDX0))
21244             ASTOT  = 0.5D0*(ASTOT1+ASTOT2)
21245             ASELA1 = ASIGEL(IDXS1,IDX0)+
21246      &               FAC*(ASIGEL(IDXS1,IDX1)-ASIGEL(IDXS1,IDX0))
21247             ASELA2 = ASIGEL(IDXS2,IDX0)+
21248      &               FAC*(ASIGEL(IDXS2,IDX1)-ASIGEL(IDXS2,IDX0))
21249             ASELA  = 0.5D0*(ASELA1+ASELA2)
21250          ENDIF
21251       ELSE
21252          IF (IDX0.EQ.IDX1) THEN
21253             IF (IDX0.EQ.1) THEN
21254                ASTOT = ASIGTO(IDXS,IDX0)
21255                ASELA = ASIGEL(IDXS,IDX0)
21256             ELSE
21257                DUM0   = ZERO
21258                CALL DT_PHOXS(1,1,DUM0,PLAB,PHOSTO,PHOSIN,DUM1,DUM2,0)
21259                PHOSEL = PHOSTO-PHOSIN
21260                ASTOT  = ASIGTO(IDXS,NPOINT)-APHOST+LOG10(PHOSTO)
21261                ASELA  = ASIGEL(IDXS,NPOINT)-APHOSE+LOG10(PHOSEL)
21262             ENDIF
21263          ELSE
21264             FAC = (APLAB-APL(IDX0))/(APL(IDX1)-APL(IDX0))
21265             ASTOT = ASIGTO(IDXS,IDX0)+
21266      &              FAC*(ASIGTO(IDXS,IDX1)-ASIGTO(IDXS,IDX0))
21267             ASELA = ASIGEL(IDXS,IDX0)+
21268      &              FAC*(ASIGEL(IDXS,IDX1)-ASIGEL(IDXS,IDX0))
21269          ENDIF
21270       ENDIF
21271       STOT = 10.0D0**ASTOT
21272       SELA = 10.0D0**ASELA
21273
21274       RETURN
21275       END
21276
21277 *$ CREATE DT_SIHNAB.FOR
21278 *COPY DT_SIHNAB
21279 *
21280 *===sihnab===============================================================*
21281 *
21282       SUBROUTINE DT_SIHNAB(IDP,IDT,PLAB,SIGABS)
21283
21284 **********************************************************************
21285 * Pion 2-nucleon absorption cross sections.                          *
21286 * (sigma_tot for pi+ d --> p p, pi- d --> n n                        *
21287 *  taken from Ritchie PRC 28 (1983) 926 )                            *
21288 * This version dated 18.05.96 is written by S. Roesler               *
21289 **********************************************************************
21290
21291       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21292       SAVE
21293       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY3=1.0D-3)
21294       PARAMETER (AMPR = 938.0D0,
21295      &           AMPI = 140.0D0,
21296      &           AMDE = TWO*AMPR,
21297      &           A    = -1.2D0,
21298      &           B    = 3.5D0,
21299      &           C    = 7.4D0,
21300      &           D    = 5600.0D0,
21301      &           ER   = 2136.0D0)
21302
21303       SIGABS = ZERO
21304       IF ( ((IDP.NE.13).AND.(IDP.NE.14).AND.(IDP.NE.23))
21305      &                   .OR.((IDT.NE.1).AND.(IDT.NE.8)) ) RETURN
21306       PTOT = PLAB*1.0D3
21307       EKIN = SQRT(AMPI**2+PTOT**2)-AMPI
21308       IF ((EKIN.LT.TINY3).OR.(EKIN.GT.400.0D0)) RETURN
21309       ECM  = SQRT( (AMPI+AMDE)**2+TWO*EKIN*AMDE )
21310       SIGABS = A+B/SQRT(EKIN)+C*1.0D4/((ECM-ER)**2+D)
21311 * approximate 3N-abs., I=1-abs. etc.
21312       SIGABS = SIGABS/0.40D0
21313 * pi0-absorption (rough approximation!!)
21314       IF (IDP.EQ.23) SIGABS = 0.5D0*SIGABS
21315
21316       RETURN
21317       END
21318
21319 *$ CREATE DT_SIGEMU.FOR
21320 *COPY DT_SIGEMU
21321 *
21322 *===sigemu=============================================================*
21323 *
21324       SUBROUTINE DT_SIGEMU
21325
21326 ************************************************************************
21327 * Combined cross section for target compounds.                         *
21328 * This version dated 6.4.98   is written by S. Roesler                 *
21329 ************************************************************************
21330
21331       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21332       SAVE
21333
21334       PARAMETER ( LINP = 10 ,
21335      &            LOUT = 6 ,
21336      &            LDAT = 9 )
21337
21338       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21339      &           OHALF=0.5D0,ONE=1.0D0)
21340
21341       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21342
21343 * Glauber formalism: cross sections
21344       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21345      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21346      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21347      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21348      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21349      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21350      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21351      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21352      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21353      &                BSLOPE,NEBINI,NQBINI
21354
21355 * emulsion treatment
21356       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
21357      &                NCOMPO,IEMUL
21358
21359 * nucleon-nucleon event-generator
21360       CHARACTER*8 CMODEL
21361       LOGICAL LPHOIN
21362       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
21363
21364       IF (MCGENE.NE.4) THEN
21365          WRITE(LOUT,'(A)') ' DT_SIGEMU:    Combined cross sections'
21366          WRITE(LOUT,'(15X,A)') '-----------------------'
21367       ENDIF
21368       DO 1 IE=1,NEBINI
21369          DO 2 IQ=1,NQBINI
21370             SIGTOT = ZERO
21371             SIGELA = ZERO
21372             SIGQEP = ZERO
21373             SIGQET = ZERO
21374             SIGQE2 = ZERO
21375             SIGPRO = ZERO
21376             SIGDEL = ZERO
21377             SIGDQE = ZERO
21378             ERRTOT = ZERO
21379             ERRELA = ZERO
21380             ERRQEP = ZERO
21381             ERRQET = ZERO
21382             ERRQE2 = ZERO
21383             ERRPRO = ZERO
21384             ERRDEL = ZERO
21385             ERRDQE = ZERO
21386             IF (NCOMPO.GT.0) THEN
21387                DO 3 IC=1,NCOMPO
21388                   SIGTOT = SIGTOT+EMUFRA(IC)*XSTOT(IE,IQ,IC)
21389                   SIGELA = SIGELA+EMUFRA(IC)*XSELA(IE,IQ,IC)
21390                   SIGQEP = SIGQEP+EMUFRA(IC)*XSQEP(IE,IQ,IC)
21391                   SIGQET = SIGQET+EMUFRA(IC)*XSQET(IE,IQ,IC)
21392                   SIGQE2 = SIGQE2+EMUFRA(IC)*XSQE2(IE,IQ,IC)
21393                   SIGPRO = SIGPRO+EMUFRA(IC)*XSPRO(IE,IQ,IC)
21394                   SIGDEL = SIGDEL+EMUFRA(IC)*XSDEL(IE,IQ,IC)
21395                   SIGDQE = SIGDQE+EMUFRA(IC)*XSDQE(IE,IQ,IC)
21396                   ERRTOT = ERRTOT+XETOT(IE,IQ,IC)**2
21397                   ERRELA = ERRELA+XEELA(IE,IQ,IC)**2
21398                   ERRQEP = ERRQEP+XEQEP(IE,IQ,IC)**2
21399                   ERRQET = ERRQET+XEQET(IE,IQ,IC)**2
21400                   ERRQE2 = ERRQE2+XEQE2(IE,IQ,IC)**2
21401                   ERRPRO = ERRPRO+XEPRO(IE,IQ,IC)**2
21402                   ERRDEL = ERRDEL+XEDEL(IE,IQ,IC)**2
21403                   ERRDQE = ERRDQE+XEDQE(IE,IQ,IC)**2
21404     3          CONTINUE
21405                ERRTOT = SQRT(ERRTOT)
21406                ERRELA = SQRT(ERRELA)
21407                ERRQEP = SQRT(ERRQEP)
21408                ERRQET = SQRT(ERRQET)
21409                ERRQE2 = SQRT(ERRQE2)
21410                ERRPRO = SQRT(ERRPRO)
21411                ERRDEL = SQRT(ERRDEL)
21412                ERRDQE = SQRT(ERRDQE)
21413             ELSE
21414                SIGTOT = XSTOT(IE,IQ,1)
21415                SIGELA = XSELA(IE,IQ,1)
21416                SIGQEP = XSQEP(IE,IQ,1)
21417                SIGQET = XSQET(IE,IQ,1)
21418                SIGQE2 = XSQE2(IE,IQ,1)
21419                SIGPRO = XSPRO(IE,IQ,1)
21420                SIGDEL = XSDEL(IE,IQ,1)
21421                SIGDQE = XSDQE(IE,IQ,1)
21422                ERRTOT = XETOT(IE,IQ,1)
21423                ERRELA = XEELA(IE,IQ,1)
21424                ERRQEP = XEQEP(IE,IQ,1)
21425                ERRQET = XEQET(IE,IQ,1)
21426                ERRQE2 = XEQE2(IE,IQ,1)
21427                ERRPRO = XEPRO(IE,IQ,1)
21428                ERRDEL = XEDEL(IE,IQ,1)
21429                ERRDQE = XEDQE(IE,IQ,1)
21430             ENDIF
21431             IF (MCGENE.NE.4) THEN
21432                WRITE(LOUT,1000) ECMNN(IE),Q2G(IQ)
21433  1000         FORMAT(/,1X,'E_cm =',F9.1,' GeV  Q^2 =',F6.1,' GeV^2 :',/)
21434                WRITE(LOUT,1001) SIGTOT,ERRTOT
21435  1001          FORMAT(1X,'total',32X,F10.4,' +-',F11.5,' mb')
21436                WRITE(LOUT,1002) SIGELA,ERRELA
21437  1002          FORMAT(1X,'elastic',30X,F10.4,' +-',F11.5,' mb')
21438                WRITE(LOUT,1003) SIGQEP,ERRQEP
21439  1003          FORMAT(1X,'quasi-elastic (A+B-->A+X)',12X,F10.4,' +-',
21440      &                F11.5,' mb')
21441                WRITE(LOUT,1004) SIGQET,ERRQET
21442  1004          FORMAT(1X,'quasi-elastic (A+B-->X+B)',12X,F10.4,' +-',
21443      &                F11.5,' mb')
21444                WRITE(LOUT,1005) SIGQE2,ERRQE2
21445  1005          FORMAT(1X,'quasi-elastic (A+B-->X, excl. 2-4)',3X,F10.4,
21446      &                ' +-',F11.5,' mb')
21447                WRITE(LOUT,1006) SIGPRO,ERRPRO
21448  1006          FORMAT(1X,'production',27X,F10.4,' +-',F11.5,' mb')
21449                WRITE(LOUT,1007) SIGDEL,ERRDEL
21450  1007          FORMAT(1X,'diff-el   ',27X,F10.4,' +-',F11.5,' mb')
21451                WRITE(LOUT,1008) SIGDQE,ERRDQE
21452  1008          FORMAT(1X,'diff-qel  ',27X,F10.4,' +-',F11.5,' mb')
21453             ENDIF
21454
21455     2    CONTINUE
21456     1 CONTINUE
21457
21458       RETURN
21459       END
21460
21461 *$ CREATE DT_SIGGA.FOR
21462 *COPY DT_SIGGA
21463 *
21464 *===sigga==============================================================*
21465 *
21466       SUBROUTINE DT_SIGGA(NTI,XI,Q2I,ECMI,XNUI,STOT,ETOT,SIN,EIN,STOT0)
21467
21468 ************************************************************************
21469 * Total/inelastic photon-nucleus cross sections.                       *
21470 *     !!!! Overwrites SHMAKI-initialization. Do not use it during      *
21471 *          production runs !!!!                                        *
21472 * This version dated 27.03.96 is written by S. Roesler                 *
21473 ************************************************************************
21474
21475       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21476       SAVE
21477
21478       PARAMETER ( LINP = 10 ,
21479      &            LOUT = 6 ,
21480      &            LDAT = 9 )
21481
21482       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
21483      &           OHALF=0.5D0,ONE=1.0D0)
21484       PARAMETER (AMPROT = 0.938D0)
21485
21486       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21487
21488 * Glauber formalism: cross sections
21489       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21490      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21491      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21492      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21493      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21494      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21495      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21496      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21497      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21498      &                BSLOPE,NEBINI,NQBINI
21499
21500       NT  = NTI
21501       X   = XI
21502       Q2  = Q2I
21503       ECM = ECMI
21504       XNU = XNUI
21505       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21506      &   ECM = SQRT(AMPROT**2-Q2+2.0D0*XNUI*AMPROT)
21507       CALL DT_XSGLAU(1,NT,7,X,Q2,ECM,1,1,-1)
21508       STOT  = XSTOT(1,1,1)
21509       ETOT  = XETOT(1,1,1)
21510       SIN   = XSPRO(1,1,1)
21511       EIN   = XEPRO(1,1,1)
21512
21513       RETURN
21514       END
21515
21516 *$ CREATE DT_SIGGAT.FOR
21517 *COPY DT_SIGGAT
21518 *
21519 *===siggat=============================================================*
21520 *
21521       SUBROUTINE DT_SIGGAT(Q2I,ECMI,STOT,NT)
21522
21523 ************************************************************************
21524 * Total/inelastic photon-nucleus cross sections.                       *
21525 * Uses pre-tabulated cross section.                                    *
21526 * This version dated 29.07.96 is written by S. Roesler                 *
21527 ************************************************************************
21528
21529       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21530       SAVE
21531
21532       PARAMETER ( LINP = 10 ,
21533      &            LOUT = 6 ,
21534      &            LDAT = 9 )
21535
21536       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21537      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21538
21539       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
21540
21541 * Glauber formalism: cross sections
21542       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
21543      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
21544      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
21545      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
21546      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
21547      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
21548      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
21549      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
21550      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
21551      &                BSLOPE,NEBINI,NQBINI
21552
21553       NTARG = ABS(NT)
21554       I1   = 1
21555       I2   = 1
21556       RATE = ONE
21557       IF (NEBINI.GT.1) THEN
21558          IF (ECMI.GE.ECMNN(NEBINI)) THEN
21559             I1   = NEBINI
21560             I2   = NEBINI
21561             RATE = ONE
21562          ELSEIF (ECMI.GT.ECMNN(1)) THEN
21563             DO 1 I=2,NEBINI
21564                IF (ECMI.LT.ECMNN(I)) THEN
21565                   I1   = I-1
21566                   I2   = I
21567                   RATE = (ECMI-ECMNN(I1))/(ECMNN(I2)-ECMNN(I1))
21568                   GOTO 2
21569                ENDIF
21570     1       CONTINUE
21571     2       CONTINUE
21572          ENDIF
21573       ENDIF
21574       J1   = 1
21575       J2   = 1
21576       RATQ = ONE
21577       IF (NQBINI.GT.1) THEN
21578          IF (Q2I.GE.Q2G(NQBINI)) THEN
21579             J1   = NQBINI
21580             J2   = NQBINI
21581             RATQ = ONE
21582          ELSEIF (Q2I.GT.Q2G(1)) THEN
21583             DO 3 I=2,NQBINI
21584                IF (Q2I.LT.Q2G(I)) THEN
21585                   J1   = I-1
21586                   J2   = I
21587                   RATQ = LOG10(    Q2I/MAX(Q2G(J1),TINY14))/
21588      &                   LOG10(Q2G(J2)/MAX(Q2G(J1),TINY14))
21589 C                 RATQ = (Q2I-Q2G(J1))/(Q2G(J2)-Q2G(J1))
21590                   GOTO 4
21591                ENDIF
21592     3       CONTINUE
21593     4       CONTINUE
21594          ENDIF
21595       ENDIF
21596
21597       STOT = XSTOT(I1,J1,NTARG)+
21598      &   RATE*(XSTOT(I2,J1,NTARG)-XSTOT(I1,J1,NTARG))+
21599      &   RATQ*(XSTOT(I1,J2,NTARG)-XSTOT(I1,J1,NTARG))+
21600      &   RATE*RATQ*(XSTOT(I2,J2,NTARG)-XSTOT(I1,J2,NTARG)+
21601      &              XSTOT(I1,J1,NTARG)-XSTOT(I2,J1,NTARG))
21602
21603       RETURN
21604       END
21605
21606 *$ CREATE DT_SANO.FOR
21607 *COPY DT_SANO
21608 *
21609 *===sigano=============================================================*
21610 *
21611       DOUBLE PRECISION FUNCTION DT_SANO(ECM)
21612
21613 ************************************************************************
21614 * This version dated 31.07.96 is written by S. Roesler                 *
21615 ************************************************************************
21616
21617       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21618       SAVE
21619
21620       PARAMETER ( LINP = 10 ,
21621      &            LOUT = 6 ,
21622      &            LDAT = 9 )
21623
21624       PARAMETER (TINY10=1.0D-10,TINY14=1.0D-14,
21625      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
21626       PARAMETER (NE = 8)
21627
21628 * VDM parameter for photon-nucleus interactions
21629       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21630
21631 * properties of interacting particles
21632       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
21633
21634       DIMENSION ECMANO(NE),FRAANO(NE),SIGHRD(NE)
21635       DATA ECMANO /
21636      &             0.200D+02,0.500D+02,0.100D+03,0.200D+03,0.500D+03,
21637      &             0.100D+04,0.200D+04,0.500D+04
21638      &            /
21639 * fixed cut (3 GeV/c)
21640       DATA FRAANO /
21641      &             0.085D+00,0.114D+00,0.105D+00,0.091D+00,0.073D+00,
21642      &             0.062D+00,0.054D+00,0.042D+00
21643      &            /
21644       DATA SIGHRD /
21645      &           4.0099D-04,3.3104D-03,1.1905D-02,3.6435D-02,1.3493D-01,
21646      &           3.3086D-01,7.6255D-01,2.1319D+00
21647      &            /
21648 * running cut (based on obsolete Phojet-caluclations, bugs..)
21649 C     DATA FRAANO /
21650 C    &             0.251E+00,0.313E+00,0.279E+00,0.239E+00,0.186E+00,
21651 C    &             0.167E+00,0.150E+00,0.131E+00
21652 C    &            /
21653 C     DATA SIGHRD /
21654 C    &           6.6569E-04,4.4949E-03,1.4837E-02,4.1466E-02,1.5071E-01,
21655 C    &           2.5736E-01,4.5593E-01,8.2550E-01
21656 C    &            /
21657
21658       DT_SANO = ZERO
21659       IF ((ISHAD(2).NE.1).OR.(IJPROJ.NE.7)) RETURN
21660       J1   = 0
21661       J2   = 0
21662       RATE = ONE
21663       IF (ECM.GE.ECMANO(NE)) THEN
21664          J1 = NE
21665          J2 = NE
21666       ELSEIF (ECM.GT.ECMANO(1)) THEN
21667          DO 1 IE=2,NE
21668             IF (ECM.LT.ECMANO(IE)) THEN
21669                J1   = IE-1
21670                J2   = IE
21671                RATE = LOG10(ECM/ECMANO(J1))/LOG10(ECMANO(J2)/ECMANO(J1))
21672                GOTO 2
21673             ENDIF
21674     1    CONTINUE
21675     2    CONTINUE
21676       ENDIF
21677       IF ((J1.GT.0).AND.(J2.GT.0)) THEN
21678          AFRA1  = LOG10(MAX(FRAANO(J1)*SIGHRD(J1),TINY14))
21679          AFRA2  = LOG10(MAX(FRAANO(J2)*SIGHRD(J2),TINY14))
21680          DT_SANO = 10.0D0**(AFRA1+RATE*(AFRA2-AFRA1))
21681       ENDIF
21682
21683       RETURN
21684       END
21685
21686 *$ CREATE DT_SIGGP.FOR
21687 *COPY DT_SIGGP
21688 *
21689 *===siggp==============================================================*
21690 *
21691       SUBROUTINE DT_SIGGP(XI,Q2I,ECMI,XNUI,STOT,SINE,SDIR)
21692
21693 ************************************************************************
21694 * Total/inelastic photon-nucleon cross sections.                       *
21695 * This version dated 30.04.96 is written by S. Roesler                 *
21696 ************************************************************************
21697
21698       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21699       SAVE
21700
21701       PARAMETER ( LINP = 10 ,
21702      &            LOUT = 6 ,
21703      &            LDAT = 9 )
21704
21705       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21706       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
21707      &           PI     = TWOPI/TWO,
21708      &           GEV2MB = 0.38938D0,
21709      &           ALPHEM = ONE/137.0D0)
21710
21711 * particle properties (BAMJET index convention)
21712       CHARACTER*8  ANAME
21713       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21714      &                IICH(210),IIBAR(210),K1(210),K2(210)
21715
21716 * VDM parameter for photon-nucleus interactions
21717       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21718
21719 **PHOJET105a
21720 C     CHARACTER*8 MDLNA
21721 C     COMMON /MODELS/ MDLNA(50),ISWMDL(50),PARMDL(200),IPAMDL(100)
21722 C     PARAMETER (IEETAB=10)
21723 C     COMMON /XSETAB/ SIGTAB(4,70,IEETAB),SIGECM(4,IEETAB),ISIMAX
21724 **PHOJET110
21725
21726 C  model switches and parameters
21727       CHARACTER*8 MDLNA
21728       INTEGER ISWMDL,IPAMDL
21729       DOUBLE PRECISION PARMDL
21730       COMMON /POMDLS/ MDLNA(50),ISWMDL(50),PARMDL(400),IPAMDL(400)
21731
21732 C  energy-interpolation table
21733       INTEGER IEETA2
21734       PARAMETER ( IEETA2 = 20 )
21735       INTEGER ISIMAX
21736       DOUBLE PRECISION SIGTAB,SIGECM
21737       COMMON /POTABL/ SIGTAB(4,80,IEETA2),SIGECM(4,IEETA2),ISIMAX
21738 **
21739
21740 C     PARAMETER (NPOINT=80)
21741       PARAMETER (NPOINT=16)
21742       DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
21743
21744       STOT = ZERO
21745       SINE = ZERO
21746       SDIR = ZERO
21747
21748       W2 = ECMI**2
21749       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21750      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21751       Q2 = Q2I
21752       X  = XI
21753 * photoprod.
21754       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21755          Q2 = 0.0001D0
21756          X  = Q2/(W2+Q2-AAM(1)**2)
21757 * DIS
21758       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21759          X  = Q2/(W2+Q2-AAM(1)**2)
21760       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21761          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21762       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21763          W2 = Q2*(ONE-X)/X+AAM(1)**2
21764       ELSE
21765          WRITE(LOUT,*) 'SIGGP: inconsistent input ',W2,Q2,X
21766          STOP
21767       ENDIF
21768       ECM = SQRT(W2)
21769
21770       IF (MODEGA.EQ.1) THEN
21771          SCALE = SQRT(Q2)
21772          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21773      &                                                       IDPDF)
21774 C        W = SQRT(W2)
21775
21776 C        ALLMF2 = PHO_ALLM97(Q2,W)
21777
21778 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
21779          STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
21780          SINE = ZERO
21781          SDIR = ZERO
21782       ELSEIF (MODEGA.EQ.2) THEN
21783          IF (INTRGE(1).EQ.1) THEN
21784             AMLO2 = (3.0D0*AAM(13))**2
21785          ELSEIF (INTRGE(1).EQ.2) THEN
21786             AMLO2 = AAM(33)**2
21787          ELSE
21788             AMLO2 = AAM(96)**2
21789          ENDIF
21790          IF (INTRGE(2).EQ.1) THEN
21791             AMHI2 = W2/TWO
21792          ELSEIF (INTRGE(2).EQ.2) THEN
21793             AMHI2 = W2/4.0D0
21794          ELSE
21795             AMHI2 = W2
21796          ENDIF
21797          AMHI20 = (ECM-AAM(1))**2
21798          IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
21799          XAMLO  = LOG( AMLO2+Q2 )
21800          XAMHI  = LOG( AMHI2+Q2 )
21801 **PHOJET105a
21802 C        CALL GSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21803 **PHOJET112
21804
21805          CALL PHO_GAUSET(XAMLO,XAMHI,NPOINT,ABSZX,WEIGHT)
21806
21807 **
21808          SUM  = ZERO
21809          DO 1 J=1,NPOINT
21810             AM2 = EXP(ABSZX(J))-Q2
21811             IF (AM2.LT.16.0D0) THEN
21812                R = TWO
21813             ELSEIF ((AM2.GE.16.0D0).AND.(AM2.LT.121.0D0)) THEN
21814                R = 10.0D0/3.0D0
21815             ELSE
21816                R = 11.0D0/3.0D0
21817             ENDIF
21818 C           FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21819             FAC = R * AM2/( (AM2+Q2)*(AM2+Q2+RL2) )
21820      &            * (ONE+EPSPOL*Q2/AM2)
21821             SUM = SUM+WEIGHT(J)*FAC
21822     1    CONTINUE
21823          SINE = SUM
21824          SDIR = DT_SIGVP(X,Q2)
21825          STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*SDIR
21826          SDIR = SDIR/(0.588D0+RL2+Q2)
21827 C        STOT = ALPHEM/(3.0D0*PI*(ONE-X))*SUM*DT_SIGVP(X,Q2)
21828       ELSEIF (MODEGA.EQ.3) THEN
21829          CALL DT_SIGGA(1,XI,Q2I,ECMI,ZERO,STOT,ETOT,SINE,EINE,DUM)
21830       ELSEIF (MODEGA.EQ.4) THEN
21831 *  load cross sections from PHOJET interpolation table
21832          IP = 1
21833          IF(ECM.LE.SIGECM(IP,1)) THEN
21834            I1 = 1
21835            I2 = 1
21836          ELSEIF (ECM.LT.SIGECM(IP,ISIMAX)) THEN
21837            DO 2 I=2,ISIMAX
21838               IF (ECM.LE.SIGECM(IP,I)) GOTO 3
21839     2      CONTINUE
21840     3      CONTINUE
21841            I1 = I-1
21842            I2 = I
21843          ELSE
21844            WRITE(LOUT,'(/1X,A,2E12.3)')
21845      &       'SIGGP:WARNING:TOO HIGH ENERGY',ECM,SIGECM(IP,ISIMAX)
21846            I1 = ISIMAX
21847            I2 = ISIMAX
21848          ENDIF
21849          FAC2 = ZERO
21850          IF (I1.NE.I2) FAC2 = LOG(ECM/SIGECM(IP,I1))
21851      &                       /LOG(SIGECM(IP,I2)/SIGECM(IP,I1))
21852          FAC1 = ONE-FAC2
21853 *  cross section dependence on photon virtuality
21854          FSUP1 = ZERO
21855          DO 4 I=1,3
21856             FSUP1 = FSUP1+PARMDL(26+I)*(1.D0+Q2/(4.D0*PARMDL(30+I)))
21857      &                                /(1.D0+Q2/PARMDL(30+I))**2
21858     4    CONTINUE
21859          FSUP1 = FSUP1+PARMDL(30)/(1.D0+Q2/PARMDL(34))
21860          FAC1  = FAC1*FSUP1
21861          FAC2  = FAC2*FSUP1
21862          FSUP2 = 1.0D0
21863          STOT  = FAC2*SIGTAB(IP, 1,I2)+FAC1*SIGTAB(IP, 1,I1)
21864          SINE  = FAC2*SIGTAB(IP,28,I2)+FAC1*SIGTAB(IP,28,I1)
21865          SDIR  = FAC2*SIGTAB(IP,29,I2)+FAC1*SIGTAB(IP,29,I1)
21866 **re:
21867          STOT  = STOT-SDIR
21868 **
21869          SDIR  = SDIR/(FSUP1*FSUP2)
21870 **re:
21871          STOT  = STOT+SDIR
21872 **
21873       ENDIF
21874
21875       RETURN
21876       END
21877
21878 *$ CREATE DT_SIGVEL.FOR
21879 *COPY DT_SIGVEL
21880 *
21881 *===sigvel=============================================================*
21882 *
21883       SUBROUTINE DT_SIGVEL(XI,Q2I,ECMI,XNUI,IDXV,SVEL,SIG1,SIG2)
21884
21885 ************************************************************************
21886 * Cross section for elastic vector meson production                    *
21887 * This version dated 10.05.96 is written by S. Roesler                 *
21888 ************************************************************************
21889
21890       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21891       SAVE
21892
21893       PARAMETER ( LINP = 10 ,
21894      &            LOUT = 6 ,
21895      &            LDAT = 9 )
21896
21897       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21898       PARAMETER (TWOPI  = 6.283185307179586476925286766559D+00,
21899      &           PI     = TWOPI/TWO,
21900      &           GEV2MB = 0.38938D0,
21901      &           ALPHEM = ONE/137.0D0)
21902
21903 * particle properties (BAMJET index convention)
21904       CHARACTER*8  ANAME
21905       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
21906      &                IICH(210),IIBAR(210),K1(210),K2(210)
21907
21908 * VDM parameter for photon-nucleus interactions
21909       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21910
21911       W2 = ECMI**2
21912       IF ((ECMI.LE.ZERO).AND.(XNUI.GT.ZERO))
21913      &   W2 = AAM(1)**2-Q2I+TWO*XNUI*AAM(1)
21914       Q2 = Q2I
21915       X  = XI
21916 * photoprod.
21917       IF ((X.LE.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21918          Q2 = 0.0001D0
21919          X  = Q2/(W2+Q2-AAM(1)**2)
21920 * DIS
21921       ELSEIF ((X.LE.ZERO).AND.(Q2.GT.ZERO).AND.(W2.GT.ZERO)) THEN
21922          X  = Q2/(W2+Q2-AAM(1)**2)
21923       ELSEIF ((X.GT.ZERO).AND.(Q2.LE.ZERO).AND.(W2.GT.ZERO)) THEN
21924          Q2 = (W2-AAM(1)**2)*X/(ONE-X)
21925       ELSEIF ((X.GT.ZERO).AND.(Q2.GT.ZERO)) THEN
21926          W2 = Q2*(ONE-X)/X+AAM(1)**2
21927       ELSE
21928          WRITE(LOUT,*) 'SIGVEL: inconsistent input ',W2,Q2,X
21929          STOP
21930       ENDIF
21931       ECM = SQRT(W2)
21932
21933       AMV  = AAM(IDXV)
21934       AMV2 = AMV**2
21935
21936       BSLOPE = 2.0D0*(2.0D0+AAM(32)**2/(AMV2+Q2)
21937      &        +0.25D0*LOG(W2/(AMV2+Q2)))*GEV2MB
21938       ROSH   = 0.1D0
21939       STOVP  = DT_SIGVP(X,Q2)/(AMV2+Q2+RL2)
21940       SELVP  = STOVP**2*(ONE+ROSH**2)/(8.0D0*TWOPI*BSLOPE)
21941
21942       IF (IDXV.EQ.33) THEN
21943          COUPL = 0.00365D0
21944       ELSE
21945          STOP
21946       ENDIF
21947       SIG1 = (AMV2/(AMV2+Q2))**2 * (ONE+EPSPOL*Q2/AMV2)
21948       SIG2 = SELVP
21949       SVEL  = COUPL * (AMV2/(AMV2+Q2))**2
21950      &              * (ONE+EPSPOL*Q2/AMV2) * SELVP
21951
21952       RETURN
21953       END
21954
21955 *$ CREATE DT_SIGVP.FOR
21956 *COPY DT_SIGVP
21957 *
21958 *===sigvp==============================================================*
21959 *
21960       DOUBLE PRECISION FUNCTION DT_SIGVP(XI,Q2I)
21961
21962 ************************************************************************
21963 * sigma_Vp                                                             *
21964 ************************************************************************
21965
21966       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
21967       SAVE
21968
21969       PARAMETER ( LINP = 10 ,
21970      &            LOUT = 6 ,
21971      &            LDAT = 9 )
21972
21973       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
21974       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
21975      &           PI    = TWOPI/TWO,
21976      &           GEV2MB = 0.38938D0,
21977      &           AMPROT = 0.938D0,
21978      &           ALPHEM = ONE/137.0D0)
21979
21980 * VDM parameter for photon-nucleus interactions
21981       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
21982
21983       X  = XI
21984       Q2 = Q2I
21985       IF (XI.LE.ZERO)  X  = 0.0001D0
21986       IF (Q2I.LE.ZERO) Q2 = 0.0001D0
21987
21988       ECM    = SQRT( Q2*(ONE-X)/X+AMPROT**2 )
21989
21990       SCALE = SQRT(Q2)
21991       IF (MODEGA.EQ.1) THEN
21992          CALL DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,F2,
21993      &                                                       IDPDF)
21994 C        W = ECM
21995
21996 C        ALLMF2 = PHO_ALLM97(Q2,W)
21997
21998 C        write(*,*) 'X,Q2,W,F2,ALLMF2',X,Q2,W,F2,ALLMF2
21999 C        STOT = TWOPI**2*ALPHEM/(Q2*(ONE-X)) * F2 *GEV2MB
22000 C        DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))
22001          DT_SIGVP = 12.0D0*PI**3.0D0*F2/(Q2*DT_RRM2(X,Q2))*GEV2MB
22002       ELSEIF (MODEGA.EQ.4) THEN
22003          CALL DT_SIGGP(X,Q2,ECM,DUM1,STOT,DUM2,DUM3)
22004 C        F2 = Q2*(ONE-X)/(TWOPI**2*ALPHEM*GEV2MB) * STOT
22005          DT_SIGVP = 3.0D0*PI/(ALPHEM*DT_RRM2(X,Q2)) * STOT
22006       ELSE
22007          STOP ' DT_SIGVP: F2 not defined for this MODEGA !'
22008       ENDIF
22009
22010       RETURN
22011
22012       END
22013
22014 *$ CREATE DT_RRM2.FOR
22015 *COPY DT_RRM2
22016 *
22017 *===RRM2===============================================================*
22018 *
22019       DOUBLE PRECISION FUNCTION DT_RRM2(X,Q2)
22020
22021       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22022       SAVE
22023
22024       PARAMETER ( LINP = 10 ,
22025      &            LOUT = 6 ,
22026      &            LDAT = 9 )
22027
22028       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22029       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22030      &           PI    = TWOPI/TWO,
22031      &           GEV2MB = 0.38938D0)
22032
22033 * particle properties (BAMJET index convention)
22034       CHARACTER*8  ANAME
22035       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22036      &                IICH(210),IIBAR(210),K1(210),K2(210)
22037
22038 * VDM parameter for photon-nucleus interactions
22039       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22040
22041       S   = Q2*(ONE-X)/X+AAM(1)**2
22042       ECM = SQRT(S)
22043
22044       IF (INTRGE(1).EQ.1) THEN
22045          AMLO2 = (3.0D0*AAM(13))**2
22046       ELSEIF (INTRGE(1).EQ.2) THEN
22047          AMLO2 = AAM(33)**2
22048       ELSE
22049          AMLO2 = AAM(96)**2
22050       ENDIF
22051       IF (INTRGE(2).EQ.1) THEN
22052          AMHI2 = S/TWO
22053       ELSEIF (INTRGE(2).EQ.2) THEN
22054          AMHI2 = S/4.0D0
22055       ELSE
22056          AMHI2 = S
22057       ENDIF
22058       AMHI20 = (ECM-AAM(1))**2
22059       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22060
22061       AM1C2 = 16.0D0
22062       AM2C2 = 121.0D0
22063       IF (AMHI2.LE.AM1C2) THEN
22064          DT_RRM2 = TWO*DT_RM2(AMLO2,AMHI2,Q2)
22065       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22066          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22067      &          10.0D0/3.0D0*DT_RM2(AM1C2,AMHI2,Q2)
22068       ELSE
22069          DT_RRM2 = TWO*DT_RM2(AMLO2,AM1C2,Q2)+
22070      &          10.0D0/3.0D0*DT_RM2(AM1C2,AM2C2,Q2)+
22071      &          11.0D0/3.0D0*DT_RM2(AM2C2,AMHI2,Q2)
22072       ENDIF
22073
22074       RETURN
22075       END
22076
22077 *$ CREATE DT_RM2.FOR
22078 *COPY DT_RM2
22079 *
22080 *===RM2================================================================*
22081 *
22082       DOUBLE PRECISION FUNCTION DT_RM2(AMLO2,AMHI2,Q2)
22083
22084       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22085       SAVE
22086
22087       PARAMETER ( LINP = 10 ,
22088      &            LOUT = 6 ,
22089      &            LDAT = 9 )
22090
22091       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
22092       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22093      &           PI    = TWOPI/TWO,
22094      &           GEV2MB = 0.38938D0)
22095
22096 * VDM parameter for photon-nucleus interactions
22097       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22098
22099       IF (RL2.LE.ZERO) THEN
22100          DT_RM2 = -ONE/(AMHI2+Q2)+Q2/(TWO*(AMHI2+Q2)**2) -
22101      &        (-ONE/(AMLO2+Q2)+Q2/(TWO*(AMLO2+Q2)**2))
22102      &         +EPSPOL*(-Q2/(TWO*(AMHI2+Q2)**2)+Q2/(TWO*(AMLO2+Q2)**2))
22103       ELSE
22104          TMPMLO = LOG(ONE+RL2/(AMLO2+Q2))
22105          TMPMHI = LOG(ONE+RL2/(AMHI2+Q2))
22106          DT_RM2 = Q2/(RL2*(AMHI2+Q2))-(Q2+RL2)/RL2**2*TMPMHI
22107      &       -(Q2/(RL2*(AMLO2+Q2))-(Q2+RL2)/RL2**2*TMPMLO)
22108      &       +EPSPOL*(
22109      &         -Q2/(RL2*(AMHI2+Q2))+Q2/RL2**2*TMPMHI
22110      &       -(-Q2/(RL2*(AMLO2+Q2))+Q2/RL2**2*TMPMLO))
22111       ENDIF
22112
22113       RETURN
22114       END
22115
22116 *$ CREATE DT_SAM2.FOR
22117 *COPY DT_SAM2
22118 *
22119 *===SAM2===============================================================*
22120 *
22121       DOUBLE PRECISION FUNCTION DT_SAM2(Q2,ECM)
22122
22123       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22124       SAVE
22125
22126       PARAMETER ( LINP = 10 ,
22127      &            LOUT = 6 ,
22128      &            LDAT = 9 )
22129
22130       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0,
22131      &           TENTRD=10.0D0/3.0D0,ELVTRD=11.0D0/3.0D0)
22132       PARAMETER (TWOPI = 6.283185307179586476925286766559D+00,
22133      &           PI    = TWOPI/TWO,
22134      &           GEV2MB = 0.38938D0)
22135
22136 * particle properties (BAMJET index convention)
22137       CHARACTER*8  ANAME
22138       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
22139      &                IICH(210),IIBAR(210),K1(210),K2(210)
22140
22141 * VDM parameter for photon-nucleus interactions
22142       COMMON /DTVDMP/ RL2,EPSPOL,INTRGE(2),IDPDF,MODEGA,ISHAD(3)
22143
22144       S = ECM**2
22145       IF (INTRGE(1).EQ.1) THEN
22146          AMLO2 = (3.0D0*AAM(13))**2
22147       ELSEIF (INTRGE(1).EQ.2) THEN
22148          AMLO2 = AAM(33)**2
22149       ELSE
22150          AMLO2 = AAM(96)**2
22151       ENDIF
22152       IF (INTRGE(2).EQ.1) THEN
22153          AMHI2 = S/TWO
22154       ELSEIF (INTRGE(2).EQ.2) THEN
22155          AMHI2 = S/4.0D0
22156       ELSE
22157          AMHI2 = S
22158       ENDIF
22159       AMHI20 = (ECM-AAM(1))**2
22160       IF (AMHI2.GE.AMHI20) AMHI2 = AMHI20
22161
22162       AM1C2 = 16.0D0
22163       AM2C2 = 121.0D0
22164       YLO   = LOG(AMLO2+Q2)
22165       YC1   = LOG(AM1C2+Q2)
22166       YC2   = LOG(AM2C2+Q2)
22167       YHI   = LOG(AMHI2+Q2)
22168       IF (AMHI2.LE.AM1C2) THEN
22169          FACHI = TWO
22170       ELSEIF ((AMHI2.GT.AM1C2).AND.(AMHI2.LE.AM2C2)) THEN
22171          FACHI = TENTRD
22172       ELSE
22173          FACHI = ELVTRD
22174       ENDIF
22175
22176     1 CONTINUE
22177       YSAM2  = YLO+(YHI-YLO)*DT_RNDM(AM1C2)
22178       IF (YSAM2.LE.YC1) THEN
22179          FAC = TWO
22180       ELSEIF ((YSAM2.GT.YC1).AND.(YSAM2.LE.YC2)) THEN
22181          FAC = TENTRD
22182       ELSE
22183          FAC = ELVTRD
22184       ENDIF
22185       WEIGMX = FACHI*(ONE-Q2*EXP(  -YHI))
22186       XSAM2  = FAC  *(ONE-Q2*EXP(-YSAM2))
22187       IF (DT_RNDM(YSAM2)*WEIGMX.GT.XSAM2) GOTO 1
22188
22189       DT_SAM2   = EXP(YSAM2)-Q2
22190
22191       RETURN
22192       END
22193
22194 *$ CREATE DT_CKMT.FOR
22195 *COPY DT_CKMT
22196 *
22197 *===ckmt===============================================================*
22198 *
22199       SUBROUTINE DT_CKMT(X,SCALE,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL,
22200      &                F2,IPAR)
22201
22202 ************************************************************************
22203 * This version dated 31.01.96 is written by S. Roesler                 *
22204 ************************************************************************
22205
22206       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22207       SAVE
22208
22209       PARAMETER ( LINP = 10 ,
22210      &            LOUT = 6 ,
22211      &            LDAT = 9 )
22212
22213       PARAMETER (ZERO=0.0D0,TWO=2.0D0,TINY10=1.0D-10)
22214
22215       PARAMETER (Q02 = 2.0D0,
22216      &           DQ2 = 10.05D0,
22217      &           Q12 = Q02+DQ2)
22218
22219       DIMENSION PD(-6:6),SEA(3),VAL(2)
22220
22221       CALL DT_PDF0(Q02,X,F2Q0,VAL,SEA,GLU,IPAR)
22222       CALL DT_PDF0(Q12,X,F2Q1,VAL,SEA,GLU,IPAR)
22223       ADQ2 = LOG10(Q12)-LOG10(Q02)
22224       F2P  = (F2Q1-F2Q0)/ADQ2
22225       CALL DT_CKMTX(IPAR,X,Q02,PD,F2PQ0)
22226       CALL DT_CKMTX(IPAR,X,Q12,PD,F2PQ1)
22227       F2PP = (F2PQ1-F2PQ0)/ADQ2
22228       FX   = (F2P-F2PP)/(F2PP+LOG(DQ2)*F2PQ0+TINY10)*Q02
22229
22230       Q2     = MAX(SCALE**2.0D0,TINY10)
22231       SMOOTH = 1.0D0+FX*(Q2-Q02)/Q2**2
22232       IF (Q2.LT.Q02) THEN
22233          CALL DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22234          UPV  = VAL(1)
22235          DNV  = VAL(2)
22236          USEA = SEA(1)
22237          DSEA = SEA(2)
22238          STR  = SEA(3)
22239          CHM  = 0.0D0
22240          BOT  = 0.0D0
22241          TOP  = 0.0D0
22242          GL   = GLU
22243       ELSE
22244          CALL DT_CKMTX(IPAR,X,Q2,PD,F2)
22245          F2 = F2*SMOOTH
22246          UPV  = PD(2)-PD(3)
22247          DNV  = PD(1)-PD(3)
22248          USEA = PD(3)
22249          DSEA = PD(3)
22250          STR  = PD(3)
22251          CHM  = PD(4)
22252          BOT  = PD(5)
22253          TOP  = PD(6)
22254          GL   = PD(0)
22255 C        UPV  = UPV*SMOOTH
22256 C        DNV  = DNV*SMOOTH
22257 C        USEA = USEA*SMOOTH
22258 C        DSEA = DSEA*SMOOTH
22259 C        STR  = STR*SMOOTH
22260 C        CHM  = CHM*SMOOTH
22261 C        GL   = GL*SMOOTH
22262       ENDIF
22263
22264       RETURN
22265       END
22266 C
22267
22268 *$ CREATE DT_CKMTX.FOR
22269 *COPY DT_CKMTX
22270       SUBROUTINE DT_CKMTX(IPAR,X,SCALE2,PD,F2)
22271 C**********************************************************************
22272 C
22273 C     PDF based on Regge theory, evolved with .... by ....
22274 C
22275 C     input: IPAR     2212   proton (not installed)
22276 C                       45   Pomeron
22277 C                      100   Deuteron
22278 C
22279 C     output: PD(-6:6) x*f(x)  parton distribution functions
22280 C            (PDFLIB convention: d = PD(1), u = PD(2) )
22281 C
22282 C**********************************************************************
22283
22284       SAVE
22285       DOUBLE PRECISION  X,SCALE2,PD(-6:6),CDN,CUP,F2
22286
22287       PARAMETER ( LINP = 10 ,
22288      &            LOUT = 6 ,
22289      &            LDAT = 9 )
22290
22291       DIMENSION QQ(7)
22292 C
22293       Q2=SNGL(SCALE2)
22294       Q1S=Q2
22295       XX=SNGL(X)
22296 C  QCD lambda for evolution
22297       OWLAM = 0.23D0
22298       OWLAM2=OWLAM**2
22299 C  Q0**2 for evolution
22300       Q02 = 2.D0
22301 C
22302 C
22303 C  the conventions are : q(1)=x*u, q(2)=x*d, q(3)=q(4)=x*sbar=x*ubar=...
22304 C                        q(6)=x*charm, q(7)=x*gluon
22305 C
22306       SB=0.
22307       IF(Q2-Q02) 1,1,2
22308     2 SB=LOG(LOG(Q2/OWLAM2)/LOG(Q02/OWLAM2))
22309     1 CONTINUE
22310       IF(IPAR.EQ.2212) THEN
22311         CALL DT_CKMTPR(1,0,XX,SB,QQ(1))
22312         CALL DT_CKMTPR(2,0,XX,SB,QQ(2))
22313         CALL DT_CKMTPR(3,0,XX,SB,QQ(3))
22314         CALL DT_CKMTPR(4,0,XX,SB,QQ(4))
22315         CALL DT_CKMTPR(5,0,XX,SB,QQ(5))
22316         CALL DT_CKMTPR(8,0,XX,SB,QQ(6))
22317         CALL DT_CKMTPR(7,0,XX,SB,QQ(7))
22318 C     ELSEIF (IPAR.EQ.45) THEN
22319 C       CALL CKMTPO(1,0,XX,SB,QQ(1))
22320 C       CALL CKMTPO(2,0,XX,SB,QQ(2))
22321 C       CALL CKMTPO(3,0,XX,SB,QQ(3))
22322 C       CALL CKMTPO(4,0,XX,SB,QQ(4))
22323 C       CALL CKMTPO(5,0,XX,SB,QQ(5))
22324 C       CALL CKMTPO(8,0,XX,SB,QQ(6))
22325 C       CALL CKMTPO(7,0,XX,SB,QQ(7))
22326       ELSEIF (IPAR.EQ.100) THEN
22327         CALL DT_CKMTDE(1,0,XX,SB,QQ(1))
22328         CALL DT_CKMTDE(2,0,XX,SB,QQ(2))
22329         CALL DT_CKMTDE(3,0,XX,SB,QQ(3))
22330         CALL DT_CKMTDE(4,0,XX,SB,QQ(4))
22331         CALL DT_CKMTDE(5,0,XX,SB,QQ(5))
22332         CALL DT_CKMTDE(8,0,XX,SB,QQ(6))
22333         CALL DT_CKMTDE(7,0,XX,SB,QQ(7))
22334       ELSE
22335         WRITE(LOUT,'(1X,A,I4,A)')
22336      &     'CKMTX:   IPAR =',IPAR,' not implemented!'
22337         STOP
22338       ENDIF
22339 C
22340       PD(-6) = 0.D0
22341       PD(-5) = 0.D0
22342       PD(-4) = DBLE(QQ(6))
22343       PD(-3) = DBLE(QQ(3))
22344       PD(-2) = DBLE(QQ(4))
22345       PD(-1) = DBLE(QQ(5))
22346       PD(0)  = DBLE(QQ(7))
22347       PD(1)  = DBLE(QQ(2))
22348       PD(2)  = DBLE(QQ(1))
22349       PD(3)  = DBLE(QQ(3))
22350       PD(4)  = DBLE(QQ(6))
22351       PD(5)  = 0.D0
22352       PD(6)  = 0.D0
22353       IF(IPAR.EQ.45) THEN
22354         CDN = (PD(1)-PD(-1))/2.D0
22355         CUP = (PD(2)-PD(-2))/2.D0
22356         PD(-1) = PD(-1) + CDN
22357         PD(-2) = PD(-2) + CUP
22358         PD(1) = PD(-1)
22359         PD(2) = PD(-2)
22360       ENDIF
22361       F2 = 4.0D0/9.0D0*(PD(2)-PD(3)+2.0D0*PD(3))+
22362      &     1.0D0/9.0D0*(PD(1)-PD(3)+2.0D0*PD(3))+
22363      &     1.0D0/9.0D0*(2.0D0*PD(3))+4.0D0/9.0D0*(2.0D0*PD(4))
22364       END
22365 C
22366
22367 *$ CREATE DT_PDF0.FOR
22368 *COPY DT_PDF0
22369 *
22370 *===pdf0===============================================================*
22371 *
22372       SUBROUTINE DT_PDF0(Q2,X,F2,VAL,SEA,GLU,IPAR)
22373
22374 ************************************************************************
22375 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22376 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22377 *                   IPAR  = 2212   proton                              *
22378 *                         =  100   deuteron                            *
22379 * This version dated 31.01.96 is written by S. Roesler                 *
22380 ************************************************************************
22381
22382       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22383       SAVE
22384
22385       PARAMETER ( LINP = 10 ,
22386      &            LOUT = 6 ,
22387      &            LDAT = 9 )
22388
22389       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22390
22391       PARAMETER (
22392      &              AA     = 0.1502D0,
22393      &              BBDEU  = 1.2D0,
22394      &              BUD    = 0.754D0,
22395      &              BDD    = 0.4495D0,
22396      &              BUP    = 1.2064D0,
22397      &              BDP    = 0.1798D0,
22398      &              DELTA0 = 0.07684D0,
22399      &              D      = 1.117D0,
22400      &              C      = 3.5489D0,
22401      &              A      = 0.2631D0,
22402      &              B      = 0.6452D0,
22403      &              ALPHAR = 0.415D0,
22404      &              E      = 0.1D0
22405      &          )
22406
22407       PARAMETER (NPOINT=16)
22408 C     DIMENSION ABSZX(NPOINT),WEIGHT(NPOINT)
22409       DIMENSION SEA(3),VAL(2)
22410
22411       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22412       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22413 * proton, deuteron
22414       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22415          CALL DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22416          SEA(1) = 0.75D0*SEA0
22417          SEA(2) = SEA(1)
22418          SEA(3) = SEA(1)
22419          VAL(1) = 9.0D0/4.0D0*VALU0
22420          VAL(2) = 9.0D0*VALD0
22421          GLU0   = SEA(1)/(1.0D0-X)
22422          F2     = SEA0+VALU0+VALD0
22423          F2PDF  = 4.0D0/9.0D0*(VAL(1)+2.0D0*SEA(1))+
22424      &            1.0D0/9.0D0*(VAL(2)+2.0D0*SEA(2))+
22425      &            1.0D0/9.0D0*(2.0D0*SEA(3))
22426          IF (ABS(F2-F2PDF).GT.TINY9) THEN
22427             WRITE(LOUT,'(1X,A,2E15.5)') 'inconsistent PDF! ',F2,F2PDF
22428             STOP
22429          ENDIF
22430 **PHOJET105a
22431 C        CALL GSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22432 **PHOJET112
22433
22434 C        CALL PHO_GAUSET(ZERO,ONE,NPOINT,ABSZX,WEIGHT)
22435
22436 **
22437 C        SUMQ = ZERO
22438 C        SUMG = ZERO
22439 C        DO 1 J=1,NPOINT
22440 C           CALL DT_CKMTQ0(Q2,ABSZX(J),IPAR,VALU0,VALD0,SEA0)
22441 C           VALU0 = 9.0D0/4.0D0*VALU0
22442 C           VALD0 = 9.0D0*VALD0
22443 C           SEA0  = 0.75D0*SEA0
22444 C           SUMQ  = SUMQ+ (VALU0+VALD0+6.0D0*SEA0) *WEIGHT(J)
22445 C           SUMG  = SUMG+ (SEA0/(1.0D0-ABSZX(J)))  *WEIGHT(J)
22446 C   1    CONTINUE
22447 C        GLU = GLU0*(1.0D0-SUMQ)/SUMG
22448       ELSE
22449          WRITE(LOUT,'(1X,A,I4,A)')
22450      &      'PDF0:   IPAR =',IPAR,' not implemented!'
22451          STOP
22452       ENDIF
22453
22454       RETURN
22455       END
22456
22457 *$ CREATE DT_CKMTQ0.FOR
22458 *COPY DT_CKMTQ0
22459 *
22460 *===ckmtq0=============================================================*
22461 *
22462       SUBROUTINE DT_CKMTQ0(Q2,X,IPAR,VALU0,VALD0,SEA0)
22463
22464 ************************************************************************
22465 * This subroutine calculates F_2 and PDF below Q^2=Q_0^2=2 GeV^2       *
22466 * an F_2-ansatz given in Capella et al. PLB 337(1994)358.              *
22467 *                   IPAR  = 2212   proton                              *
22468 *                         =  100   deuteron                            *
22469 * This version dated 31.01.96 is written by S. Roesler                 *
22470 ************************************************************************
22471
22472       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
22473       SAVE
22474
22475       PARAMETER ( LINP = 10 ,
22476      &            LOUT = 6 ,
22477      &            LDAT = 9 )
22478
22479       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY9=1.0D-9)
22480
22481       PARAMETER (
22482      &              AA     = 0.1502D0,
22483      &              BBDEU  = 1.2D0,
22484      &              BUD    = 0.754D0,
22485      &              BDD    = 0.4495D0,
22486      &              BUP    = 1.2064D0,
22487      &              BDP    = 0.1798D0,
22488      &              DELTA0 = 0.07684D0,
22489      &              D      = 1.117D0,
22490      &              C      = 3.5489D0,
22491      &              A      = 0.2631D0,
22492      &              B      = 0.6452D0,
22493      &              ALPHAR = 0.415D0,
22494      &              E      = 0.1D0
22495      &          )
22496
22497       DELTA = DELTA0*(1.0D0+2.0D0*Q2/(Q2+D))
22498       AN    = 1.5D0*(1.0D0+Q2/(Q2+C))
22499 * proton, deuteron
22500       IF ((IPAR.EQ.2212).OR.(IPAR.EQ.100)) THEN
22501          IF (IPAR.EQ.2212) THEN
22502             BU = BUP
22503             BD = BDP
22504          ELSE
22505             BU = BUD
22506             BD = BDD
22507          ENDIF
22508          SEA0  = AA*X**(-DELTA)*(1.0D0-X)**(AN+4.0D0)*
22509      &          (Q2/(Q2+A))**(1.0D0+DELTA)
22510          VALU0 = BU*X**(1.0D0-ALPHAR)*(1.0D0-X)**AN*
22511      &           (Q2/(Q2+B))**(ALPHAR)
22512          VALD0 = BD*X**(1.0D0-ALPHAR)*(1.0D0-X)**(AN+1.0D0)*
22513      &           (Q2/(Q2+B))**(ALPHAR)
22514       ELSE
22515          WRITE(LOUT,'(1X,A,I4,A)')
22516      &      'CKMTQ0: IPAR =',IPAR,' not implemented!'
22517          STOP
22518       ENDIF
22519       RETURN
22520       END
22521 C
22522 C
22523
22524 *$ CREATE DT_CKMTDE.FOR
22525 *COPY DT_CKMTDE
22526       SUBROUTINE DT_CKMTDE(I,NDRV,X,S,ANS)
22527 C
22528 C**********************************************************************
22529 C    Deuteron - PDFs
22530 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
22531 C    ANS = PDF(I)
22532 C    This version by S. Roesler, 30.01.96
22533 C**********************************************************************
22534
22535       SAVE
22536       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
22537       EQUIVALENCE (GF(1,1,1),DL(1))
22538       DATA DELTA/.13/
22539 C
22540       DATA (DL(K),K=    1,   85) /
22541      &0.351858E+00,0.388489E+00,0.325356E+00,0.325356E+00,0.325356E+00,
22542      &0.325356E+00,0.445218E+01,0.000000E+00,0.419818E+00,0.459249E+00,
22543      &0.391167E+00,0.391143E+00,0.391125E+00,0.391167E+00,0.628186E+01,
22544      &0.703797E-01,0.498333E+00,0.540626E+00,0.467466E+00,0.467423E+00,
22545      &0.467393E+00,0.467466E+00,0.837368E+01,0.151191E+00,0.587839E+00,
22546      &0.633058E+00,0.554689E+00,0.554630E+00,0.554595E+00,0.554689E+00,
22547      &0.107170E+02,0.242877E+00,0.688652E+00,0.736861E+00,0.653150E+00,
22548      &0.653080E+00,0.653046E+00,0.653150E+00,0.132960E+02,0.345760E+00,
22549      &0.800961E+00,0.852226E+00,0.763038E+00,0.762961E+00,0.762933E+00,
22550      &0.763038E+00,0.160884E+02,0.460033E+00,0.924829E+00,0.979213E+00,
22551      &0.884414E+00,0.884335E+00,0.884319E+00,0.884414E+00,0.190679E+02,
22552      &0.585764E+00,0.106016E+01,0.111773E+01,0.101719E+01,0.101711E+01,
22553      &0.101711E+01,0.101719E+01,0.222033E+02,0.722864E+00,0.120670E+01,
22554      &0.126752E+01,0.116110E+01,0.116102E+01,0.116105E+01,0.116110E+01,
22555      &0.254603E+02,0.871079E+00,0.136402E+01,0.142815E+01,0.131571E+01,
22556      &0.131565E+01,0.131570E+01,0.131571E+01,0.288020E+02,0.102998E+01,
22557      &0.153151E+01,0.159900E+01,0.148043E+01,0.148038E+01,0.148046E+01/
22558       DATA (DL(K),K=   86,  170) /
22559      &0.148043E+01,0.321898E+02,0.119897E+01,0.170838E+01,0.177930E+01,
22560      &0.165447E+01,0.165444E+01,0.165455E+01,0.165447E+01,0.355845E+02,
22561      &0.137726E+01,0.189369E+01,0.196807E+01,0.183687E+01,0.183686E+01,
22562      &0.183701E+01,0.183687E+01,0.389473E+02,0.156390E+01,0.208631E+01,
22563      &0.216422E+01,0.202653E+01,0.202654E+01,0.202673E+01,0.202653E+01,
22564      &0.422402E+02,0.175779E+01,0.228501E+01,0.236648E+01,0.222220E+01,
22565      &0.222224E+01,0.222248E+01,0.222220E+01,0.454277E+02,0.195768E+01,
22566      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22567      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22568      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22569      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.326035E+00,0.380777E+00,0.286363E+00,0.286363E+00,0.286363E+00,
22575      &0.286363E+00,0.392252E+01,-.138778E-16,0.380092E+00,0.438587E+00/
22576       DATA (DL(K),K=  171,  255) /
22577      &0.337452E+00,0.337430E+00,0.337424E+00,0.337452E+00,0.532193E+01,
22578      &0.553645E-01,0.440879E+00,0.503177E+00,0.395208E+00,0.395169E+00,
22579      &0.395165E+00,0.395208E+00,0.686454E+01,0.117354E+00,0.508415E+00,
22580      &0.574566E+00,0.459649E+00,0.459600E+00,0.459604E+00,0.459649E+00,
22581      &0.853316E+01,0.185994E+00,0.582647E+00,0.652699E+00,0.530722E+00,
22582      &0.530667E+00,0.530687E+00,0.530722E+00,0.103093E+02,0.261237E+00,
22583      &0.663404E+00,0.737405E+00,0.608254E+00,0.608199E+00,0.608241E+00,
22584      &0.608254E+00,0.121710E+02,0.342917E+00,0.750429E+00,0.828423E+00,
22585      &0.691990E+00,0.691941E+00,0.692009E+00,0.691990E+00,0.140946E+02,
22586      &0.430783E+00,0.843361E+00,0.925391E+00,0.781571E+00,0.781533E+00,
22587      &0.781632E+00,0.781571E+00,0.160553E+02,0.524479E+00,0.941741E+00,
22588      &0.102784E+01,0.876538E+00,0.876515E+00,0.876650E+00,0.876538E+00,
22589      &0.180277E+02,0.623549E+00,0.104501E+01,0.113521E+01,0.976335E+00,
22590      &0.976332E+00,0.976506E+00,0.976335E+00,0.199863E+02,0.727439E+00,
22591      &0.115251E+01,0.124685E+01,0.108031E+01,0.108034E+01,0.108055E+01,
22592      &0.108031E+01,0.219066E+02,0.835506E+00,0.126352E+01,0.136201E+01,
22593      &0.118775E+01,0.118780E+01,0.118806E+01,0.118775E+01,0.237652E+02/
22594       DATA (DL(K),K=  256,  340) /
22595      &0.947020E+00,0.137724E+01,0.147989E+01,0.129783E+01,0.129791E+01,
22596      &0.129822E+01,0.129783E+01,0.255406E+02,0.106119E+01,0.149279E+01,
22597      &0.159961E+01,0.140972E+01,0.140984E+01,0.141019E+01,0.140972E+01,
22598      &0.272135E+02,0.117715E+01,0.160929E+01,0.172028E+01,0.152252E+01,
22599      &0.152267E+01,0.152308E+01,0.152252E+01,0.287669E+02,0.129402E+01,
22600      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22601      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22602      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22603      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.309785E+00,0.391282E+00,0.250518E+00,0.250518E+00,0.250518E+00,
22609      &0.250518E+00,0.343842E+01,-.138778E-16,0.352113E+00,0.438463E+00,
22610      &0.288877E+00,0.288863E+00,0.288878E+00,0.288877E+00,0.446765E+01,
22611      &0.424850E-01,0.398382E+00,0.489596E+00,0.331132E+00,0.331111E+00/
22612       DATA (DL(K),K=  341,  425) /
22613      &0.331148E+00,0.331132E+00,0.555902E+01,0.888369E-01,0.448375E+00,
22614      &0.544458E+00,0.377064E+00,0.377043E+00,0.377108E+00,0.377064E+00,
22615      &0.669490E+01,0.138845E+00,0.501854E+00,0.602811E+00,0.426440E+00,
22616      &0.426425E+00,0.426523E+00,0.426440E+00,0.785892E+01,0.192281E+00,
22617      &0.558506E+00,0.664331E+00,0.478946E+00,0.478944E+00,0.479079E+00,
22618      &0.478946E+00,0.903368E+01,0.248834E+00,0.617972E+00,0.728657E+00,
22619      &0.534229E+00,0.534244E+00,0.534421E+00,0.534229E+00,0.102022E+02,
22620      &0.308155E+00,0.679844E+00,0.795370E+00,0.591883E+00,0.591921E+00,
22621      &0.592141E+00,0.591883E+00,0.113479E+02,0.369841E+00,0.743667E+00,
22622      &0.864009E+00,0.651460E+00,0.651525E+00,0.651792E+00,0.651460E+00,
22623      &0.124553E+02,0.433447E+00,0.808951E+00,0.934073E+00,0.712474E+00,
22624      &0.712571E+00,0.712885E+00,0.712474E+00,0.135102E+02,0.498486E+00,
22625      &0.875171E+00,0.100503E+01,0.774408E+00,0.774541E+00,0.774902E+00,
22626      &0.774408E+00,0.144999E+02,0.564446E+00,0.941784E+00,0.107632E+01,
22627      &0.836726E+00,0.836897E+00,0.837307E+00,0.836726E+00,0.154136E+02,
22628      &0.630788E+00,0.100823E+01,0.114738E+01,0.898879E+00,0.899092E+00,
22629      &0.899551E+00,0.898879E+00,0.162423E+02,0.696967E+00,0.107396E+01/
22630       DATA (DL(K),K=  426,  510) /
22631      &0.121764E+01,0.960319E+00,0.960577E+00,0.961084E+00,0.960319E+00,
22632      &0.169791E+02,0.762433E+00,0.113843E+01,0.128655E+01,0.102051E+01,
22633      &0.102081E+01,0.102137E+01,0.102051E+01,0.176190E+02,0.826647E+00,
22634      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22635      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22636      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22637      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+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.304680E+00,0.425088E+00,0.216504E+00,0.216504E+00,0.216504E+00,
22643      &0.216504E+00,0.298356E+01,0.000000E+00,0.337300E+00,0.463627E+00,
22644      &0.244023E+00,0.244024E+00,0.244063E+00,0.244023E+00,0.370271E+01,
22645      &0.316585E-01,0.371787E+00,0.503942E+00,0.273415E+00,0.273423E+00,
22646      &0.273505E+00,0.273415E+00,0.443039E+01,0.651685E-01,0.407853E+00,
22647      &0.545739E+00,0.304395E+00,0.304418E+00,0.304545E+00,0.304395E+00/
22648       DATA (DL(K),K=  511,  595) /
22649      &0.515321E+01,0.100252E+00,0.445229E+00,0.588741E+00,0.336700E+00,
22650      &0.336744E+00,0.336918E+00,0.336700E+00,0.586004E+01,0.136648E+00,
22651      &0.483606E+00,0.632629E+00,0.370026E+00,0.370095E+00,0.370318E+00,
22652      &0.370026E+00,0.654027E+01,0.174056E+00,0.522666E+00,0.677074E+00,
22653      &0.404062E+00,0.404162E+00,0.404433E+00,0.404062E+00,0.718442E+01,
22654      &0.212167E+00,0.562075E+00,0.721735E+00,0.438483E+00,0.438618E+00,
22655      &0.438938E+00,0.438483E+00,0.778423E+01,0.250658E+00,0.601494E+00,
22656      &0.766258E+00,0.472959E+00,0.473131E+00,0.473500E+00,0.472959E+00,
22657      &0.833276E+01,0.289199E+00,0.640580E+00,0.810290E+00,0.507156E+00,
22658      &0.507369E+00,0.507784E+00,0.507156E+00,0.882448E+01,0.327457E+00,
22659      &0.678993E+00,0.853479E+00,0.540747E+00,0.541003E+00,0.541463E+00,
22660      &0.540747E+00,0.925529E+01,0.365104E+00,0.716405E+00,0.895483E+00,
22661      &0.573411E+00,0.573714E+00,0.574216E+00,0.573411E+00,0.962250E+01,
22662      &0.401821E+00,0.752501E+00,0.935975E+00,0.604848E+00,0.605197E+00,
22663      &0.605740E+00,0.604848E+00,0.992478E+01,0.437304E+00,0.786987E+00,
22664      &0.974647E+00,0.634775E+00,0.635173E+00,0.635752E+00,0.634775E+00,
22665      &0.101620E+02,0.471269E+00,0.819594E+00,0.101122E+01,0.662936E+00/
22666       DATA (DL(K),K=  596,  680) /
22667      &0.663382E+00,0.663995E+00,0.662936E+00,0.103354E+02,0.503459E+00,
22668      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22669      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22670      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22671      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+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.312661E+00,0.487836E+00,0.182562E+00,0.182562E+00,0.182562E+00,
22677      &0.182562E+00,0.253626E+01,0.000000E+00,0.336910E+00,0.518440E+00,
22678      &0.200702E+00,0.200721E+00,0.200779E+00,0.200702E+00,0.299460E+01,
22679      &0.224425E-01,0.361554E+00,0.549164E+00,0.219359E+00,0.219402E+00,
22680      &0.219517E+00,0.219359E+00,0.343183E+01,0.453742E-01,0.386348E+00,
22681      &0.579759E+00,0.238296E+00,0.238367E+00,0.238536E+00,0.238296E+00,
22682      &0.384076E+01,0.685610E-01,0.411080E+00,0.610003E+00,0.257305E+00,
22683      &0.257408E+00,0.257630E+00,0.257305E+00,0.421619E+01,0.917987E-01/
22684       DATA (DL(K),K=  681,  765) /
22685      &0.435528E+00,0.639668E+00,0.276174E+00,0.276313E+00,0.276583E+00,
22686      &0.276174E+00,0.455400E+01,0.114876E+00,0.459476E+00,0.668531E+00,
22687      &0.294698E+00,0.294875E+00,0.295191E+00,0.294698E+00,0.485107E+01,
22688      &0.137589E+00,0.482719E+00,0.696375E+00,0.312682E+00,0.312900E+00,
22689      &0.313258E+00,0.312682E+00,0.510539E+01,0.159742E+00,0.505060E+00,
22690      &0.722995E+00,0.329941E+00,0.330200E+00,0.330596E+00,0.329941E+00,
22691      &0.531589E+01,0.181149E+00,0.526315E+00,0.748199E+00,0.346303E+00,
22692      &0.346604E+00,0.347034E+00,0.346303E+00,0.548250E+01,0.201638E+00,
22693      &0.546317E+00,0.771808E+00,0.361613E+00,0.361957E+00,0.362418E+00,
22694      &0.361613E+00,0.560595E+01,0.221052E+00,0.564917E+00,0.793667E+00,
22695      &0.375735E+00,0.376122E+00,0.376609E+00,0.375735E+00,0.568772E+01,
22696      &0.239253E+00,0.581987E+00,0.813638E+00,0.388553E+00,0.388982E+00,
22697      &0.389491E+00,0.388553E+00,0.572992E+01,0.256122E+00,0.597419E+00,
22698      &0.831608E+00,0.399972E+00,0.400443E+00,0.400970E+00,0.399972E+00,
22699      &0.573516E+01,0.271562E+00,0.611129E+00,0.847487E+00,0.409919E+00,
22700      &0.410430E+00,0.410972E+00,0.409919E+00,0.570642E+01,0.285497E+00,
22701      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22702       DATA (DL(K),K=  766,  850) /
22703      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22704      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22705      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22706      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.335149E+00,0.582072E+00,0.146415E+00,0.146415E+00,0.146415E+00,
22711      &0.146415E+00,0.206772E+01,0.000000E+00,0.351552E+00,0.603437E+00,
22712      &0.156515E+00,0.156542E+00,0.156595E+00,0.156515E+00,0.231143E+01,
22713      &0.146091E-01,0.367407E+00,0.623737E+00,0.166387E+00,0.166442E+00,
22714      &0.166542E+00,0.166387E+00,0.252488E+01,0.289315E-01,0.382571E+00,
22715      &0.642832E+00,0.175891E+00,0.175976E+00,0.176118E+00,0.175891E+00,
22716      &0.270658E+01,0.428312E-01,0.396926E+00,0.660609E+00,0.184917E+00,
22717      &0.185034E+00,0.185212E+00,0.184917E+00,0.285608E+01,0.561981E-01,
22718      &0.410365E+00,0.676962E+00,0.193365E+00,0.193513E+00,0.193722E+00,
22719      &0.193365E+00,0.297375E+01,0.689319E-01,0.422792E+00,0.691796E+00/
22720       DATA (DL(K),K=  851,  935) /
22721      &0.201144E+00,0.201324E+00,0.201560E+00,0.201144E+00,0.306050E+01,
22722      &0.809434E-01,0.434123E+00,0.705030E+00,0.208181E+00,0.208393E+00,
22723      &0.208650E+00,0.208181E+00,0.311775E+01,0.921567E-01,0.444287E+00,
22724      &0.716596E+00,0.214413E+00,0.214656E+00,0.214931E+00,0.214413E+00,
22725      &0.314738E+01,0.102508E+00,0.453228E+00,0.726441E+00,0.219792E+00,
22726      &0.220066E+00,0.220354E+00,0.219792E+00,0.315156E+01,0.111949E+00,
22727      &0.460906E+00,0.734527E+00,0.224285E+00,0.224589E+00,0.224886E+00,
22728      &0.224285E+00,0.313271E+01,0.120441E+00,0.467291E+00,0.740835E+00,
22729      &0.227870E+00,0.228203E+00,0.228506E+00,0.227870E+00,0.309338E+01,
22730      &0.127963E+00,0.472372E+00,0.745357E+00,0.230541E+00,0.230902E+00,
22731      &0.231208E+00,0.230541E+00,0.303621E+01,0.134506E+00,0.476148E+00,
22732      &0.748105E+00,0.232304E+00,0.232690E+00,0.232996E+00,0.232304E+00,
22733      &0.296381E+01,0.140070E+00,0.478635E+00,0.749103E+00,0.233176E+00,
22734      &0.233586E+00,0.233889E+00,0.233176E+00,0.287874E+01,0.144672E+00,
22735      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22736      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22737      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22738       DATA (DL(K),K=  936, 1020) /
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22743      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22744      &0.370162E+00,0.695827E+00,0.105823E+00,0.105823E+00,0.105823E+00,
22745      &0.105823E+00,0.154556E+01,0.208167E-16,0.378214E+00,0.703794E+00,
22746      &0.109539E+00,0.109554E+00,0.109571E+00,0.109539E+00,0.162770E+01,
22747      &0.818783E-02,0.385258E+00,0.710067E+00,0.112818E+00,0.112847E+00,
22748      &0.112879E+00,0.112818E+00,0.168578E+01,0.158212E-01,0.391264E+00,
22749      &0.714648E+00,0.115620E+00,0.115666E+00,0.115709E+00,0.115620E+00,
22750      &0.172175E+01,0.228667E-01,0.396214E+00,0.717539E+00,0.117923E+00,
22751      &0.117985E+00,0.118037E+00,0.117923E+00,0.173756E+01,0.293009E-01,
22752      &0.400098E+00,0.718759E+00,0.119711E+00,0.119790E+00,0.119848E+00,
22753      &0.119711E+00,0.173541E+01,0.351123E-01,0.402915E+00,0.718332E+00,
22754      &0.120979E+00,0.121074E+00,0.121137E+00,0.120979E+00,0.171755E+01,
22755      &0.402951E-01,0.404672E+00,0.716292E+00,0.121728E+00,0.121840E+00/
22756       DATA (DL(K),K= 1021, 1105) /
22757      &0.121905E+00,0.121728E+00,0.168619E+01,0.448514E-01,0.405385E+00,
22758      &0.712681E+00,0.121967E+00,0.122095E+00,0.122161E+00,0.121967E+00,
22759      &0.164352E+01,0.487902E-01,0.405077E+00,0.707551E+00,0.121712E+00,
22760      &0.121855E+00,0.121920E+00,0.121712E+00,0.159162E+01,0.521265E-01,
22761      &0.403778E+00,0.700963E+00,0.120984E+00,0.121141E+00,0.121204E+00,
22762      &0.120984E+00,0.153245E+01,0.548814E-01,0.401525E+00,0.692984E+00,
22763      &0.119809E+00,0.119980E+00,0.120040E+00,0.119809E+00,0.146780E+01,
22764      &0.570807E-01,0.398361E+00,0.683691E+00,0.118218E+00,0.118402E+00,
22765      &0.118457E+00,0.118218E+00,0.139928E+01,0.587542E-01,0.394333E+00,
22766      &0.673166E+00,0.116244E+00,0.116440E+00,0.116490E+00,0.116244E+00,
22767      &0.132834E+01,0.599355E-01,0.389495E+00,0.661496E+00,0.113924E+00,
22768      &0.114131E+00,0.114175E+00,0.113924E+00,0.125620E+01,0.606602E-01,
22769      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22770      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22771      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22772      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22773      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
22774       DATA (DL(K),K= 1106, 1190) /
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      &0.394012E+00,0.757115E+00,0.772117E-01,0.772117E-01,0.772117E-01,
22779      &0.772117E-01,0.117279E+01,0.346945E-17,0.395841E+00,0.752988E+00,
22780      &0.780501E-01,0.780655E-01,0.780723E-01,0.780501E-01,0.118528E+01,
22781      &0.491697E-02,0.396627E+00,0.747223E+00,0.785386E-01,0.785692E-01,
22782      &0.785806E-01,0.785386E-01,0.118242E+01,0.932754E-02,0.396401E+00,
22783      &0.739901E+00,0.786820E-01,0.787273E-01,0.787413E-01,0.786820E-01,
22784      &0.116673E+01,0.132427E-01,0.395190E+00,0.731092E+00,0.784870E-01,
22785      &0.785464E-01,0.785613E-01,0.784870E-01,0.114033E+01,0.166738E-01,
22786      &0.393030E+00,0.720878E+00,0.779683E-01,0.780410E-01,0.780555E-01,
22787      &0.779683E-01,0.110528E+01,0.196392E-01,0.389962E+00,0.709342E+00,
22788      &0.771427E-01,0.772280E-01,0.772409E-01,0.771427E-01,0.106344E+01,
22789      &0.221591E-01,0.386027E+00,0.696571E+00,0.760304E-01,0.761276E-01,
22790      &0.761378E-01,0.760304E-01,0.101653E+01,0.242567E-01,0.381274E+00,
22791      &0.682657E+00,0.746543E-01,0.747623E-01,0.747692E-01,0.746543E-01/
22792       DATA (DL(K),K= 1191, 1275) /
22793      &0.966057E+00,0.259571E-01,0.375752E+00,0.667695E+00,0.730389E-01,
22794      &0.731569E-01,0.731598E-01,0.730389E-01,0.913345E+00,0.272876E-01,
22795      &0.369514E+00,0.651782E+00,0.712104E-01,0.713374E-01,0.713358E-01,
22796      &0.712104E-01,0.859530E+00,0.282763E-01,0.362616E+00,0.635021E+00,
22797      &0.691957E-01,0.693307E-01,0.693243E-01,0.691957E-01,0.805566E+00,
22798      &0.289524E-01,0.355116E+00,0.617511E+00,0.670220E-01,0.671640E-01,
22799      &0.671526E-01,0.670220E-01,0.752235E+00,0.293453E-01,0.347072E+00,
22800      &0.599357E+00,0.647162E-01,0.648642E-01,0.648478E-01,0.647162E-01,
22801      &0.700161E+00,0.294844E-01,0.338543E+00,0.580659E+00,0.623046E-01,
22802      &0.624578E-01,0.624363E-01,0.623046E-01,0.649828E+00,0.293983E-01,
22803      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22804      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22805      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22806      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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       DATA (DL(K),K= 1276, 1360) /
22811      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22812      &0.408305E+00,0.775318E+00,0.509141E-01,0.509141E-01,0.509141E-01,
22813      &0.509141E-01,0.818839E+00,-.867362E-17,0.403619E+00,0.758058E+00,
22814      &0.502245E-01,0.502351E-01,0.502337E-01,0.502245E-01,0.795347E+00,
22815      &0.264045E-02,0.398068E+00,0.739709E+00,0.493454E-01,0.493661E-01,
22816      &0.493626E-01,0.493454E-01,0.764942E+00,0.491508E-02,0.391719E+00,
22817      &0.720394E+00,0.482952E-01,0.483253E-01,0.483192E-01,0.482952E-01,
22818      &0.729624E+00,0.685202E-02,0.384627E+00,0.700222E+00,0.470896E-01,
22819      &0.471285E-01,0.471194E-01,0.470896E-01,0.690906E+00,0.847433E-02,
22820      &0.376851E+00,0.679300E+00,0.457475E-01,0.457946E-01,0.457822E-01,
22821      &0.457475E-01,0.650078E+00,0.980774E-02,0.368452E+00,0.657739E+00,
22822      &0.442875E-01,0.443419E-01,0.443261E-01,0.442875E-01,0.608239E+00,
22823      &0.108769E-01,0.359490E+00,0.635646E+00,0.427281E-01,0.427892E-01,
22824      &0.427698E-01,0.427281E-01,0.566280E+00,0.117061E-01,0.350026E+00,
22825      &0.613128E+00,0.410878E-01,0.411549E-01,0.411320E-01,0.410878E-01,
22826      &0.524918E+00,0.123191E-01,0.340122E+00,0.590292E+00,0.393848E-01,
22827      &0.394571E-01,0.394308E-01,0.393848E-01,0.484713E+00,0.127393E-01/
22828       DATA (DL(K),K= 1361, 1445) /
22829      &0.329838E+00,0.567240E+00,0.376363E-01,0.377132E-01,0.376836E-01,
22830      &0.376363E-01,0.446084E+00,0.129888E-01,0.319236E+00,0.544074E+00,
22831      &0.358589E-01,0.359396E-01,0.359068E-01,0.358589E-01,0.409328E+00,
22832      &0.130888E-01,0.308374E+00,0.520890E+00,0.340678E-01,0.341517E-01,
22833      &0.341160E-01,0.340678E-01,0.374641E+00,0.130594E-01,0.297312E+00,
22834      &0.497781E+00,0.322772E-01,0.323636E-01,0.323253E-01,0.322772E-01,
22835      &0.342135E+00,0.129195E-01,0.286106E+00,0.474837E+00,0.304999E-01,
22836      &0.305882E-01,0.305474E-01,0.304999E-01,0.311854E+00,0.126863E-01,
22837      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22838      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22839      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22840      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.407248E+00,0.746438E+00,0.335640E-01,0.335640E-01,0.335640E-01/
22846       DATA (DL(K),K= 1446, 1530) /
22847      &0.335640E-01,0.573540E+00,0.173472E-16,0.397516E+00,0.719825E+00,
22848      &0.324649E-01,0.324735E-01,0.324698E-01,0.324649E-01,0.540770E+00,
22849      &0.147177E-02,0.387197E+00,0.692869E+00,0.312911E-01,0.313075E-01,
22850      &0.313000E-01,0.312911E-01,0.505972E+00,0.269995E-02,0.376365E+00,
22851      &0.665689E+00,0.300576E-01,0.300811E-01,0.300699E-01,0.300576E-01,
22852      &0.470389E+00,0.371147E-02,0.365085E+00,0.638387E+00,0.287770E-01,
22853      &0.288070E-01,0.287922E-01,0.287770E-01,0.434885E+00,0.452768E-02,
22854      &0.353423E+00,0.611066E+00,0.274623E-01,0.274980E-01,0.274797E-01,
22855      &0.274623E-01,0.400103E+00,0.516996E-02,0.341442E+00,0.583823E+00,
22856      &0.261256E-01,0.261663E-01,0.261448E-01,0.261256E-01,0.366541E+00,
22857      &0.565807E-02,0.329207E+00,0.556753E+00,0.247782E-01,0.248234E-01,
22858      &0.247989E-01,0.247782E-01,0.334555E+00,0.601048E-02,0.316777E+00,
22859      &0.529946E+00,0.234308E-01,0.234798E-01,0.234525E-01,0.234308E-01,
22860      &0.304384E+00,0.624451E-02,0.304214E+00,0.503489E+00,0.220932E-01,
22861      &0.221452E-01,0.221155E-01,0.220932E-01,0.276170E+00,0.637618E-02,
22862      &0.291575E+00,0.477462E+00,0.207739E-01,0.208286E-01,0.207966E-01,
22863      &0.207739E-01,0.249976E+00,0.642028E-02,0.278917E+00,0.451941E+00/
22864       DATA (DL(K),K= 1531, 1615) /
22865      &0.194809E-01,0.195376E-01,0.195037E-01,0.194809E-01,0.225809E+00,
22866      &0.639038E-02,0.266293E+00,0.426995E+00,0.182209E-01,0.182791E-01,
22867      &0.182436E-01,0.182209E-01,0.203629E+00,0.629880E-02,0.253754E+00,
22868      &0.402686E+00,0.169996E-01,0.170587E-01,0.170219E-01,0.169996E-01,
22869      &0.183361E+00,0.615665E-02,0.241347E+00,0.379071E+00,0.158217E-01,
22870      &0.158814E-01,0.158436E-01,0.158217E-01,0.164907E+00,0.597385E-02,
22871      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22872      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22873      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22874      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.395106E+00,0.689399E+00,0.218554E-01,0.218554E-01,0.218554E-01,
22880      &0.218554E-01,0.398362E+00,-.173472E-17,0.381441E+00,0.656777E+00,
22881      &0.207816E-01,0.207886E-01,0.207844E-01,0.207816E-01,0.366703E+00/
22882       DATA (DL(K),K= 1616, 1700) /
22883      &0.826643E-03,0.367505E+00,0.624578E+00,0.197001E-01,0.197133E-01,
22884      &0.197053E-01,0.197001E-01,0.335573E+00,0.149886E-02,0.353373E+00,
22885      &0.592889E+00,0.186195E-01,0.186383E-01,0.186266E-01,0.186195E-01,
22886      &0.305590E+00,0.203730E-02,0.339106E+00,0.561783E+00,0.175468E-01,
22887      &0.175705E-01,0.175555E-01,0.175468E-01,0.277136E+00,0.245817E-02,
22888      &0.324766E+00,0.531331E+00,0.164887E-01,0.165166E-01,0.164986E-01,
22889      &0.164887E-01,0.250424E+00,0.277666E-02,0.310411E+00,0.501599E+00,
22890      &0.154510E-01,0.154825E-01,0.154618E-01,0.154510E-01,0.225588E+00,
22891      &0.300658E-02,0.296100E+00,0.472648E+00,0.144390E-01,0.144735E-01,
22892      &0.144504E-01,0.144390E-01,0.202681E+00,0.316040E-02,0.281885E+00,
22893      &0.444535E+00,0.134570E-01,0.134940E-01,0.134689E-01,0.134570E-01,
22894      &0.181693E+00,0.324944E-02,0.267820E+00,0.417309E+00,0.125091E-01,
22895      &0.125481E-01,0.125212E-01,0.125091E-01,0.162572E+00,0.328396E-02,
22896      &0.253953E+00,0.391017E+00,0.115984E-01,0.116389E-01,0.116106E-01,
22897      &0.115984E-01,0.145235E+00,0.327313E-02,0.240328E+00,0.365695E+00,
22898      &0.107275E-01,0.107690E-01,0.107396E-01,0.107275E-01,0.129575E+00,
22899      &0.322510E-02,0.226989E+00,0.341375E+00,0.989805E-02,0.994030E-02/
22900       DATA (DL(K),K= 1701, 1785) /
22901      &0.990998E-02,0.989805E-02,0.115477E+00,0.314713E-02,0.213972E+00,
22902      &0.318081E+00,0.911149E-02,0.915408E-02,0.912316E-02,0.911149E-02,
22903      &0.102820E+00,0.304556E-02,0.201311E+00,0.295830E+00,0.836852E-02,
22904      &0.841111E-02,0.837984E-02,0.836852E-02,0.914804E-01,0.292596E-02,
22905      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22906      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22907      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22908      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.374678E+00,0.616087E+00,0.139531E-01,0.139531E-01,0.139531E-01,
22914      &0.139531E-01,0.272491E+00,-.693889E-17,0.358052E+00,0.580345E+00,
22915      &0.130624E-01,0.130680E-01,0.130641E-01,0.130624E-01,0.245861E+00,
22916      &0.460255E-03,0.341487E+00,0.545719E+00,0.121971E-01,0.122076E-01,
22917      &0.122002E-01,0.121971E-01,0.220877E+00,0.826785E-03,0.325046E+00/
22918       DATA (DL(K),K= 1786, 1870) /
22919      &0.512244E+00,0.113599E-01,0.113748E-01,0.113641E-01,0.113599E-01,
22920      &0.197730E+00,0.111366E-02,0.308783E+00,0.479952E+00,0.105534E-01,
22921      &0.105720E-01,0.105585E-01,0.105534E-01,0.176497E+00,0.133192E-02,
22922      &0.292747E+00,0.448868E+00,0.977938E-02,0.980112E-02,0.978518E-02,
22923      &0.977938E-02,0.157150E+00,0.149139E-02,0.276986E+00,0.419015E+00,
22924      &0.903955E-02,0.906394E-02,0.904584E-02,0.903955E-02,0.139631E+00,
22925      &0.160093E-02,0.261546E+00,0.390412E+00,0.833509E-02,0.836165E-02,
22926      &0.834171E-02,0.833509E-02,0.123850E+00,0.166838E-02,0.246467E+00,
22927      &0.363074E+00,0.766687E-02,0.769516E-02,0.767369E-02,0.766687E-02,
22928      &0.109695E+00,0.170073E-02,0.231787E+00,0.337008E+00,0.703540E-02,
22929      &0.706500E-02,0.704230E-02,0.703540E-02,0.970428E-01,0.170416E-02,
22930      &0.217542E+00,0.312218E+00,0.644083E-02,0.647137E-02,0.644772E-02,
22931      &0.644083E-02,0.857658E-01,0.168409E-02,0.203759E+00,0.288701E+00,
22932      &0.588300E-02,0.591415E-02,0.588981E-02,0.588300E-02,0.757385E-01,
22933      &0.164528E-02,0.190467E+00,0.266449E+00,0.536147E-02,0.539292E-02,
22934      &0.536812E-02,0.536147E-02,0.668383E-01,0.159185E-02,0.177686E+00,
22935      &0.245447E+00,0.487551E-02,0.490698E-02,0.488195E-02,0.487551E-02/
22936       DATA (DL(K),K= 1871, 1955) /
22937      &0.589492E-01,0.152735E-02,0.165434E+00,0.225677E+00,0.442416E-02,
22938      &0.445543E-02,0.443037E-02,0.442416E-02,0.519652E-01,0.145483E-02,
22939      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22940      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22941      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22942      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.348042E+00,0.534691E+00,0.867977E-02,0.867977E-02,0.867977E-02,
22948      &0.867977E-02,0.182547E+00,-.693889E-17,0.329349E+00,0.498248E+00,
22949      &0.800724E-02,0.801198E-02,0.800836E-02,0.800724E-02,0.161948E+00,
22950      &0.250949E-03,0.311047E+00,0.463485E+00,0.737155E-02,0.738040E-02,
22951      &0.737356E-02,0.737155E-02,0.143267E+00,0.447662E-03,0.293181E+00,
22952      &0.430377E+00,0.677169E-02,0.678409E-02,0.677441E-02,0.677169E-02,
22953      &0.126447E+00,0.598803E-03,0.275787E+00,0.398907E+00,0.620726E-02/
22954       DATA (DL(K),K= 1956, 2040) /
22955      &0.622265E-02,0.621051E-02,0.620726E-02,0.111401E+00,0.711280E-03,
22956      &0.258900E+00,0.369051E+00,0.567741E-02,0.569532E-02,0.568106E-02,
22957      &0.567741E-02,0.979944E-01,0.790986E-03,0.242550E+00,0.340785E+00,
22958      &0.518138E-02,0.520134E-02,0.518531E-02,0.518138E-02,0.860936E-01,
22959      &0.843227E-03,0.226765E+00,0.314083E+00,0.471828E-02,0.473987E-02,
22960      &0.472238E-02,0.471828E-02,0.755615E-01,0.872644E-03,0.211568E+00,
22961      &0.288916E+00,0.428714E-02,0.430998E-02,0.429133E-02,0.428714E-02,
22962      &0.662627E-01,0.883319E-03,0.196981E+00,0.265252E+00,0.388691E-02,
22963      &0.391065E-02,0.389112E-02,0.388691E-02,0.580684E-01,0.878818E-03,
22964      &0.183020E+00,0.243053E+00,0.351645E-02,0.354077E-02,0.352060E-02,
22965      &0.351645E-02,0.508578E-01,0.862228E-03,0.169696E+00,0.222280E+00,
22966      &0.317451E-02,0.319914E-02,0.317858E-02,0.317451E-02,0.445190E-01,
22967      &0.836224E-03,0.157017E+00,0.202888E+00,0.285982E-02,0.288450E-02,
22968      &0.286376E-02,0.285982E-02,0.389523E-01,0.803096E-03,0.144987E+00,
22969      &0.184832E+00,0.257101E-02,0.259553E-02,0.257480E-02,0.257101E-02,
22970      &0.340677E-01,0.764787E-03,0.133605E+00,0.168060E+00,0.230670E-02,
22971      &0.233087E-02,0.231031E-02,0.230670E-02,0.297820E-01,0.722929E-03/
22972       DATA (DL(K),K= 2041, 2125) /
22973      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22974      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22975      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
22976      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.316867E+00,0.451111E+00,0.522815E-02,0.522815E-02,0.522815E-02,
22982      &0.522815E-02,0.119118E+00,0.889046E-17,0.296950E+00,0.415915E+00,
22983      &0.475497E-02,0.475914E-02,0.475574E-02,0.475497E-02,0.104204E+00,
22984      &0.132513E-03,0.277735E+00,0.382805E+00,0.431809E-02,0.432582E-02,
22985      &0.431944E-02,0.431809E-02,0.910279E-01,0.235347E-03,0.259241E+00,
22986      &0.351694E+00,0.391455E-02,0.392531E-02,0.391637E-02,0.391455E-02,
22987      &0.794222E-01,0.313322E-03,0.241485E+00,0.322517E+00,0.354249E-02,
22988      &0.355575E-02,0.354464E-02,0.354249E-02,0.692354E-01,0.370408E-03,
22989      &0.224480E+00,0.295202E+00,0.319987E-02,0.321518E-02,0.320226E-02/
22990       DATA (DL(K),K= 2126, 2210) /
22991      &0.319987E-02,0.603106E-01,0.409866E-03,0.208235E+00,0.269681E+00,
22992      &0.288490E-02,0.290184E-02,0.288744E-02,0.288490E-02,0.525034E-01,
22993      &0.434663E-03,0.192759E+00,0.245887E+00,0.259589E-02,0.261407E-02,
22994      &0.259852E-02,0.259589E-02,0.456838E-01,0.447393E-03,0.178054E+00,
22995      &0.223752E+00,0.233123E-02,0.235033E-02,0.233390E-02,0.233123E-02,
22996      &0.397318E-01,0.450314E-03,0.164120E+00,0.203207E+00,0.208941E-02,
22997      &0.210910E-02,0.209206E-02,0.208941E-02,0.345396E-01,0.445394E-03,
22998      &0.150954E+00,0.184182E+00,0.186896E-02,0.188897E-02,0.187155E-02,
22999      &0.186896E-02,0.300131E-01,0.434333E-03,0.138548E+00,0.166608E+00,
23000      &0.166844E-02,0.168854E-02,0.167096E-02,0.166844E-02,0.260692E-01,
23001      &0.418584E-03,0.126892E+00,0.150412E+00,0.148650E-02,0.150648E-02,
23002      &0.148891E-02,0.148650E-02,0.226325E-01,0.399380E-03,0.115971E+00,
23003      &0.135523E+00,0.132180E-02,0.134148E-02,0.132409E-02,0.132180E-02,
23004      &0.196374E-01,0.377764E-03,0.105767E+00,0.121870E+00,0.117308E-02,
23005      &0.119231E-02,0.117524E-02,0.117308E-02,0.170312E-01,0.354610E-03,
23006      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23007      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23008       DATA (DL(K),K= 2211, 2295) /
23009      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.282579E+00,0.369670E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23016      &0.302765E-02,0.752529E-01,-.455365E-17,0.262229E+00,0.337209E+00,
23017      &0.271512E-02,0.271883E-02,0.271564E-02,0.271512E-02,0.651086E-01,
23018      &0.669321E-04,0.242857E+00,0.307069E+00,0.243269E-02,0.243953E-02,
23019      &0.243360E-02,0.243269E-02,0.563252E-01,0.118744E-03,0.224455E+00,
23020      &0.279111E+00,0.217687E-02,0.218631E-02,0.217808E-02,0.217687E-02,
23021      &0.487143E-01,0.157767E-03,0.207014E+00,0.253223E+00,0.194534E-02,
23022      &0.195689E-02,0.194675E-02,0.194534E-02,0.421227E-01,0.186063E-03,
23023      &0.190523E+00,0.229293E+00,0.173585E-02,0.174909E-02,0.173741E-02,
23024      &0.173585E-02,0.364156E-01,0.205286E-03,0.174969E+00,0.207218E+00,
23025      &0.154647E-02,0.156100E-02,0.154811E-02,0.154647E-02,0.314732E-01/
23026       DATA (DL(K),K= 2296, 2380) /
23027      &0.216964E-03,0.160335E+00,0.186895E+00,0.137545E-02,0.139092E-02,
23028      &0.137713E-02,0.137545E-02,0.271927E-01,0.222455E-03,0.146604E+00,
23029      &0.168227E+00,0.122121E-02,0.123733E-02,0.122290E-02,0.122121E-02,
23030      &0.234852E-01,0.222947E-03,0.133756E+00,0.151116E+00,0.108234E-02,
23031      &0.109881E-02,0.108400E-02,0.108234E-02,0.202747E-01,0.219474E-03,
23032      &0.121765E+00,0.135471E+00,0.957502E-03,0.974107E-03,0.959112E-03,
23033      &0.957502E-03,0.174932E-01,0.212928E-03,0.110606E+00,0.121198E+00,
23034      &0.845493E-03,0.862024E-03,0.847037E-03,0.845493E-03,0.150824E-01,
23035      &0.204075E-03,0.100250E+00,0.108210E+00,0.745196E-03,0.761482E-03,
23036      &0.746662E-03,0.745196E-03,0.129965E-01,0.193573E-03,0.906661E-01,
23037      &0.964191E-01,0.655569E-03,0.671466E-03,0.656948E-03,0.655569E-03,
23038      &0.111930E-01,0.181962E-03,0.818218E-01,0.857412E-01,0.575637E-03,
23039      &0.591030E-03,0.576925E-03,0.575637E-03,0.962922E-02,0.169687E-03,
23040      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23041      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23042      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23043      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23044       DATA (DL(K),K= 2381, 2465) /
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23049      &0.246444E+00,0.293515E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23050      &0.167124E-02,0.456929E-01,-.260209E-17,0.226393E+00,0.264836E+00,
23051      &0.147748E-02,0.148085E-02,0.147783E-02,0.147748E-02,0.392393E-01,
23052      &0.318190E-04,0.207552E+00,0.238550E+00,0.130596E-02,0.131212E-02,
23053      &0.130656E-02,0.130596E-02,0.337276E-01,0.566426E-04,0.189877E+00,
23054      &0.214470E+00,0.115347E-02,0.116190E-02,0.115427E-02,0.115347E-02,
23055      &0.290012E-01,0.753776E-04,0.173336E+00,0.192452E+00,0.101789E-02,
23056      &0.102811E-02,0.101881E-02,0.101789E-02,0.249381E-01,0.889466E-04,
23057      &0.157889E+00,0.172355E+00,0.897268E-03,0.908872E-03,0.898270E-03,
23058      &0.897268E-03,0.214419E-01,0.980950E-04,0.143501E+00,0.154046E+00,
23059      &0.789951E-03,0.802565E-03,0.790996E-03,0.789951E-03,0.184296E-01,
23060      &0.103536E-03,0.130132E+00,0.137402E+00,0.694510E-03,0.707811E-03,
23061      &0.695568E-03,0.694510E-03,0.158331E-01,0.105929E-03,0.117743E+00/
23062       DATA (DL(K),K= 2466, 2550) /
23063      &0.122303E+00,0.609684E-03,0.623394E-03,0.610733E-03,0.609684E-03,
23064      &0.135929E-01,0.105853E-03,0.106293E+00,0.108637E+00,0.534365E-03,
23065      &0.548244E-03,0.535386E-03,0.534365E-03,0.116583E-01,0.103825E-03,
23066      &0.957386E-01,0.962976E-01,0.467572E-03,0.481416E-03,0.468551E-03,
23067      &0.467572E-03,0.999103E-02,0.100301E-03,0.860376E-01,0.851820E-01,
23068      &0.408422E-03,0.422062E-03,0.409350E-03,0.408422E-03,0.855563E-02,
23069      &0.956675E-04,0.771455E-01,0.751930E-01,0.356117E-03,0.369416E-03,
23070      &0.356989E-03,0.356117E-03,0.731542E-02,0.902499E-04,0.690178E-01,
23071      &0.662386E-01,0.309950E-03,0.322797E-03,0.310761E-03,0.309950E-03,
23072      &0.624633E-02,0.843305E-04,0.616096E-01,0.582312E-01,0.269281E-03,
23073      &0.281590E-03,0.270030E-03,0.269281E-03,0.533230E-02,0.781441E-04,
23074      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23075      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23076      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23077      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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       DATA (DL(K),K= 2551, 2635) /
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.209608E+00,0.224862E+00,0.869706E-03,0.869706E-03,0.869706E-03,
23084      &0.869706E-03,0.264204E-01,-.138236E-17,0.190523E+00,0.200603E+00,
23085      &0.757542E-03,0.760626E-03,0.757768E-03,0.757542E-03,0.226261E-01,
23086      &0.138827E-04,0.172819E+00,0.178656E+00,0.660281E-03,0.665837E-03,
23087      &0.660670E-03,0.660281E-03,0.194018E-01,0.249832E-04,0.156420E+00,
23088      &0.158805E+00,0.575414E-03,0.582918E-03,0.575917E-03,0.575414E-03,
23089      &0.166434E-01,0.334851E-04,0.141265E+00,0.140883E+00,0.501258E-03,
23090      &0.510252E-03,0.501836E-03,0.501258E-03,0.142710E-01,0.397017E-04,
23091      &0.127291E+00,0.124732E+00,0.436386E-03,0.446473E-03,0.437008E-03,
23092      &0.436386E-03,0.122297E-01,0.439154E-04,0.114437E+00,0.110205E+00,
23093      &0.379575E-03,0.390415E-03,0.380217E-03,0.379575E-03,0.104701E-01,
23094      &0.464110E-04,0.102644E+00,0.971655E-01,0.329805E-03,0.341109E-03,
23095      &0.330448E-03,0.329805E-03,0.895086E-02,0.474758E-04,0.918521E-01,
23096      &0.854876E-01,0.286206E-03,0.297729E-03,0.286836E-03,0.286206E-03,
23097      &0.764249E-02,0.473771E-04,0.820032E-01,0.750529E-01,0.248027E-03/
23098       DATA (DL(K),K= 2636, 2720) /
23099      &0.259564E-03,0.248633E-03,0.248027E-03,0.651744E-02,0.463561E-04,
23100      &0.730394E-01,0.657510E-01,0.214611E-03,0.225995E-03,0.215186E-03,
23101      &0.214611E-03,0.554573E-02,0.446239E-04,0.649040E-01,0.574789E-01,
23102      &0.185396E-03,0.196491E-03,0.185935E-03,0.185396E-03,0.470938E-02,
23103      &0.423722E-04,0.575411E-01,0.501405E-01,0.159891E-03,0.170590E-03,
23104      &0.160391E-03,0.159891E-03,0.399752E-02,0.397689E-04,0.508960E-01,
23105      &0.436466E-01,0.137650E-03,0.147874E-03,0.138111E-03,0.137650E-03,
23106      &0.338807E-02,0.369434E-04,0.449157E-01,0.379141E-01,0.118285E-03,
23107      &0.127973E-03,0.118705E-03,0.118285E-03,0.286125E-02,0.340035E-04,
23108      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23109      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23110      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23111      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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       DATA (DL(K),K= 2721, 2805) /
23117      &0.173133E+00,0.165162E+00,0.420483E-03,0.420483E-03,0.420483E-03,
23118      &0.420483E-03,0.143704E-01,0.418773E-17,0.155600E+00,0.145586E+00,
23119      &0.360490E-03,0.363140E-03,0.360629E-03,0.360490E-03,0.123560E-01,
23120      &0.533279E-05,0.139551E+00,0.128113E+00,0.309555E-03,0.314310E-03,
23121      &0.309792E-03,0.309555E-03,0.106262E-01,0.982612E-05,0.124876E+00,
23122      &0.112516E+00,0.265952E-03,0.272344E-03,0.266256E-03,0.265952E-03,
23123      &0.913151E-02,0.133834E-04,0.111490E+00,0.986188E-01,0.228522E-03,
23124      &0.236138E-03,0.228869E-03,0.228522E-03,0.783135E-02,0.160429E-04,
23125      &0.993081E-01,0.862590E-01,0.196336E-03,0.204821E-03,0.196706E-03,
23126      &0.196336E-03,0.670031E-02,0.178799E-04,0.882484E-01,0.752883E-01,
23127      &0.168604E-03,0.177655E-03,0.168981E-03,0.168604E-03,0.572016E-02,
23128      &0.189837E-04,0.782334E-01,0.655714E-01,0.144684E-03,0.154047E-03,
23129      &0.145058E-03,0.144684E-03,0.487276E-02,0.194655E-04,0.691885E-01,
23130      &0.569841E-01,0.124035E-03,0.133497E-03,0.124397E-03,0.124035E-03,
23131      &0.413648E-02,0.194296E-04,0.610420E-01,0.494128E-01,0.106203E-03,
23132      &0.115592E-03,0.106548E-03,0.106203E-03,0.350042E-02,0.189800E-04,
23133      &0.537249E-01,0.427533E-01,0.908141E-04,0.999895E-04,0.911377E-04/
23134       DATA (DL(K),K= 2806, 2890) /
23135      &0.908141E-04,0.295961E-02,0.182192E-04,0.471713E-01,0.369100E-01,
23136      &0.775359E-04,0.863895E-04,0.778360E-04,0.775359E-04,0.249629E-02,
23137      &0.172287E-04,0.413182E-01,0.317957E-01,0.660857E-04,0.745356E-04,
23138      &0.663611E-04,0.660857E-04,0.209482E-02,0.160791E-04,0.361056E-01,
23139      &0.273306E-01,0.562298E-04,0.642173E-04,0.564804E-04,0.562298E-04,
23140      &0.175588E-02,0.148407E-04,0.314766E-01,0.234421E-01,0.477598E-04,
23141      &0.552457E-04,0.479859E-04,0.477598E-04,0.147398E-02,0.135653E-04,
23142      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23143      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23144      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23145      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.138007E+00,0.115214E+00,0.185072E-03,0.185072E-03,0.185072E-03,
23151      &0.185072E-03,0.722856E-02,-.380826E-17,0.122517E+00,0.100251E+00/
23152       DATA (DL(K),K= 2891, 2975) /
23153      &0.155814E-03,0.158287E-03,0.155901E-03,0.155814E-03,0.630580E-02,
23154      &0.155371E-05,0.108535E+00,0.870870E-01,0.131535E-03,0.135909E-03,
23155      &0.131680E-03,0.131535E-03,0.547867E-02,0.304952E-05,0.959260E-01,
23156      &0.754985E-01,0.111183E-03,0.116980E-03,0.111366E-03,0.111183E-03,
23157      &0.473794E-02,0.433106E-05,0.845828E-01,0.653163E-01,0.940433E-04,
23158      &0.100851E-03,0.942493E-04,0.940433E-04,0.407647E-02,0.533613E-05,
23159      &0.744017E-01,0.563870E-01,0.795843E-04,0.870596E-04,0.798007E-04,
23160      &0.795843E-04,0.349165E-02,0.606691E-05,0.652864E-01,0.485720E-01,
23161      &0.673476E-04,0.752069E-04,0.675656E-04,0.673476E-04,0.297273E-02,
23162      &0.652898E-05,0.571466E-01,0.417472E-01,0.569700E-04,0.649812E-04,
23163      &0.571831E-04,0.569700E-04,0.251732E-02,0.675028E-05,0.498975E-01,
23164      &0.358008E-01,0.481618E-04,0.561391E-04,0.483654E-04,0.481618E-04,
23165      &0.212754E-02,0.677236E-05,0.434594E-01,0.306320E-01,0.406746E-04,
23166      &0.484724E-04,0.408657E-04,0.406746E-04,0.179059E-02,0.662814E-05,
23167      &0.377578E-01,0.261500E-01,0.343050E-04,0.418123E-04,0.344818E-04,
23168      &0.343050E-04,0.149563E-02,0.635273E-05,0.327229E-01,0.222734E-01,
23169      &0.288923E-04,0.360279E-04,0.290540E-04,0.288923E-04,0.124695E-02/
23170       DATA (DL(K),K= 2976, 3060) /
23171      &0.598767E-05,0.282894E-01,0.189287E-01,0.242960E-04,0.310036E-04,
23172      &0.244423E-04,0.242960E-04,0.104112E-02,0.556344E-05,0.243968E-01,
23173      &0.160504E-01,0.203920E-04,0.266363E-04,0.205232E-04,0.203920E-04,
23174      &0.863677E-03,0.510070E-05,0.209890E-01,0.135797E-01,0.170822E-04,
23175      &0.228449E-04,0.171989E-04,0.170822E-04,0.711641E-03,0.462338E-05,
23176      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23177      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23178      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23179      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.105155E+00,0.752467E-01,0.719932E-04,0.719932E-04,0.719932E-04,
23185      &0.719932E-04,0.328057E-02,-.758942E-18,0.920856E-01,0.645455E-01,
23186      &0.592305E-04,0.615087E-04,0.592802E-04,0.592305E-04,0.295327E-02,
23187      &0.945234E-07,0.804695E-01,0.552770E-01,0.489125E-04,0.528632E-04/
23188       DATA (DL(K),K= 3061, 3145) /
23189      &0.489946E-04,0.489125E-04,0.261804E-02,0.365139E-06,0.701499E-01,
23190      &0.472409E-01,0.404786E-04,0.456186E-04,0.405807E-04,0.404786E-04,
23191      &0.229460E-02,0.686912E-06,0.610049E-01,0.402864E-01,0.335367E-04,
23192      &0.394631E-04,0.336495E-04,0.335367E-04,0.198445E-02,0.981070E-06,
23193      &0.529201E-01,0.342803E-01,0.278134E-04,0.342044E-04,0.279301E-04,
23194      &0.278134E-04,0.169772E-02,0.122521E-05,0.457907E-01,0.291037E-01,
23195      &0.230821E-04,0.296833E-04,0.231978E-04,0.230821E-04,0.144575E-02,
23196      &0.140819E-05,0.395205E-01,0.246522E-01,0.191553E-04,0.257661E-04,
23197      &0.192666E-04,0.191553E-04,0.122125E-02,0.152152E-05,0.340212E-01,
23198      &0.208330E-01,0.158874E-04,0.223546E-04,0.159921E-04,0.158874E-04,
23199      &0.101912E-02,0.156880E-05,0.292116E-01,0.175644E-01,0.131678E-04,
23200      &0.193783E-04,0.132645E-04,0.131678E-04,0.847586E-03,0.156432E-05,
23201      &0.250173E-01,0.147740E-01,0.109029E-04,0.167762E-04,0.109910E-04,
23202      &0.109029E-04,0.705515E-03,0.151845E-05,0.213702E-01,0.123979E-01,
23203      &0.901273E-05,0.144953E-04,0.909200E-05,0.901273E-05,0.581767E-03,
23204      &0.143817E-05,0.182083E-01,0.103797E-01,0.743733E-05,0.124978E-04,
23205      &0.750792E-05,0.743733E-05,0.475483E-03,0.133574E-05,0.154751E-01/
23206       DATA (DL(K),K= 3146, 3230) /
23207      &0.867011E-02,0.612722E-05,0.107517E-04,0.618950E-05,0.612722E-05,
23208      &0.390116E-03,0.122183E-05,0.131193E-01,0.722560E-02,0.503734E-05,
23209      &0.922584E-05,0.509185E-05,0.503734E-05,0.319980E-03,0.110130E-05,
23210      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23211      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23212      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23213      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.754424E-01,0.449848E-01,0.236444E-04,0.236444E-04,0.236444E-04,
23219      &0.236444E-04,0.129291E-02,0.113079E-17,0.650429E-01,0.379660E-01,
23220      &0.187739E-04,0.207130E-04,0.187990E-04,0.187739E-04,0.124038E-02,
23221      &-.327995E-06,0.559588E-01,0.319936E-01,0.149625E-04,0.182671E-04,
23222      &0.150033E-04,0.149625E-04,0.113497E-02,-.464337E-06,0.480234E-01,
23223      &0.269030E-01,0.119484E-04,0.161746E-04,0.119982E-04,0.119484E-04/
23224       DATA (DL(K),K= 3231, 3315) /
23225      &0.100877E-02,-.490618E-06,0.411091E-01,0.225716E-01,0.954833E-05,
23226      &0.143391E-04,0.960250E-05,0.954833E-05,0.883852E-03,-.461770E-06,
23227      &0.350995E-01,0.188947E-01,0.763738E-05,0.127129E-04,0.769248E-05,
23228      &0.763738E-05,0.760077E-03,-.403363E-06,0.298897E-01,0.157798E-01,
23229      &0.611070E-05,0.112548E-04,0.616439E-05,0.611070E-05,0.639505E-03,
23230      &-.335607E-06,0.253856E-01,0.131470E-01,0.488993E-05,0.994021E-05,
23231      &0.494070E-05,0.488993E-05,0.534131E-03,-.267652E-06,0.215026E-01,
23232      &0.109271E-01,0.391276E-05,0.875190E-05,0.395967E-05,0.391276E-05,
23233      &0.445478E-03,-.205292E-06,0.181648E-01,0.906007E-02,0.312720E-05,
23234      &0.767418E-05,0.316978E-05,0.312720E-05,0.366232E-03,-.154024E-06,
23235      &0.153041E-01,0.749382E-02,0.249633E-05,0.670002E-05,0.253440E-05,
23236      &0.249633E-05,0.297435E-03,-.112673E-06,0.128596E-01,0.618334E-02,
23237      &0.199074E-05,0.582360E-05,0.202435E-05,0.199074E-05,0.242305E-03,
23238      &-.794410E-07,0.107770E-01,0.508977E-02,0.158457E-05,0.503733E-05,
23239      &0.161393E-05,0.158457E-05,0.196927E-03,-.546702E-07,0.900806E-02,
23240      &0.417964E-02,0.125888E-05,0.433619E-05,0.128428E-05,0.125888E-05,
23241      &0.158171E-03,-.364714E-07,0.751006E-02,0.342418E-02,0.998674E-06/
23242       DATA (DL(K),K= 3316, 3400) /
23243      &0.371518E-05,0.102046E-05,0.998674E-06,0.126865E-03,-.228706E-07,
23244      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23245      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23246      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23247      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.496787E-01,0.236961E-01,0.607312E-05,0.607312E-05,0.607312E-05,
23253      &0.607312E-05,0.415108E-03,-.140523E-17,0.420445E-01,0.196196E-01,
23254      &0.443589E-05,0.603481E-05,0.444683E-05,0.443589E-05,0.444425E-03,
23255      &-.375397E-06,0.355108E-01,0.162223E-01,0.321766E-05,0.587645E-05,
23256      &0.323504E-05,0.321766E-05,0.432635E-03,-.593989E-06,0.299148E-01,
23257      &0.133836E-01,0.231504E-05,0.562250E-05,0.233581E-05,0.231504E-05,
23258      &0.395801E-03,-.699904E-06,0.251339E-01,0.110157E-01,0.164651E-05,
23259      &0.526880E-05,0.166853E-05,0.164651E-05,0.344925E-03,-.733095E-06/
23260       DATA (DL(K),K= 3401, 3485) /
23261      &0.210605E-01,0.904539E-02,0.115940E-05,0.485739E-05,0.118122E-05,
23262      &0.115940E-05,0.294439E-03,-.715193E-06,0.175989E-01,0.740944E-02,
23263      &0.808365E-06,0.441709E-05,0.829075E-06,0.808365E-06,0.249093E-03,
23264      &-.665420E-06,0.146656E-01,0.605433E-02,0.555563E-06,0.396078E-05,
23265      &0.574607E-06,0.555563E-06,0.205675E-03,-.600648E-06,0.121872E-01,
23266      &0.493466E-02,0.375914E-06,0.350822E-05,0.393011E-06,0.375914E-06,
23267      &0.166757E-03,-.529210E-06,0.100993E-01,0.401191E-02,0.250032E-06,
23268      &0.307359E-05,0.265094E-06,0.250032E-06,0.135196E-03,-.456996E-06,
23269      &0.834582E-02,0.325348E-02,0.162261E-06,0.266488E-05,0.175325E-06,
23270      &0.162261E-06,0.108862E-03,-.388821E-06,0.687767E-02,0.263179E-02,
23271      &0.102273E-06,0.228913E-05,0.113453E-06,0.102273E-06,0.865539E-04,
23272      &-.326325E-06,0.565221E-02,0.212357E-02,0.620694E-07,0.194975E-05,
23273      &0.715290E-07,0.620694E-07,0.687156E-04,-.270547E-06,0.463248E-02,
23274      &0.170926E-02,0.351992E-07,0.164711E-05,0.431226E-07,0.351992E-07,
23275      &0.543744E-04,-.222379E-06,0.378655E-02,0.137242E-02,0.178902E-07,
23276      &0.138124E-05,0.244675E-07,0.178902E-07,0.426626E-04,-.181158E-06,
23277      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23278       DATA (DL(K),K= 3486, 3570) /
23279      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23280      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23281      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23282      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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.286141E-01,0.102357E-01,0.105702E-05,0.105702E-05,0.105702E-05,
23287      &0.105702E-05,0.963318E-04,0.591070E-18,0.236608E-01,0.827483E-02,
23288      &0.548552E-06,0.163293E-05,0.551993E-06,0.548552E-06,0.133058E-03,
23289      &-.268677E-06,0.195282E-01,0.668247E-02,0.238780E-06,0.183459E-05,
23290      &0.243802E-06,0.238780E-06,0.135119E-03,-.393414E-06,0.160742E-01,
23291      &0.538444E-02,0.599864E-07,0.183277E-05,0.655085E-07,0.599864E-07,
23292      &0.124554E-03,-.428349E-06,0.131940E-01,0.432750E-02,-.392825E-07,
23293      &0.172071E-05,-.338391E-07,-.392825E-07,0.111121E-03,-.415550E-06,
23294      &0.107996E-01,0.346954E-02,-.875089E-07,0.154604E-05,-.824926E-07,
23295      &-.875089E-07,0.941854E-04,-.376855E-06,0.881435E-02,0.277463E-02/
23296       DATA (DL(K),K= 3571, 3655) /
23297      &-.103962E-06,0.135013E-05,-.995446E-07,-.103962E-06,0.772195E-04,
23298      &-.326008E-06,0.717317E-02,0.221313E-02,-.102844E-06,0.115335E-05,
23299      &-.990733E-07,-.102844E-06,0.626565E-04,-.272858E-06,0.582050E-02,
23300      &0.176061E-02,-.929503E-07,0.967229E-06,-.898064E-07,-.929503E-07,
23301      &0.499930E-04,-.222828E-06,0.470908E-02,0.139692E-02,-.791495E-07,
23302      &0.800414E-06,-.765797E-07,-.791495E-07,0.394181E-04,-.178141E-06,
23303      &0.379875E-02,0.110542E-02,-.647230E-07,0.655119E-06,-.626567E-07,
23304      &-.647230E-07,0.309999E-04,-.140000E-06,0.305549E-02,0.872447E-03,
23305      &-.515215E-07,0.530834E-06,-.498829E-07,-.515215E-07,0.240354E-04,
23306      &-.108633E-06,0.245058E-02,0.686769E-03,-.400234E-07,0.426835E-06,
23307      &-.387401E-07,-.400234E-07,0.184613E-04,-.832544E-07,0.195984E-02,
23308      &0.539209E-03,-.304312E-07,0.341169E-06,-.294373E-07,-.304312E-07,
23309      &0.143512E-04,-.630818E-07,0.156297E-02,0.422273E-03,-.228633E-07,
23310      &0.271199E-06,-.221014E-07,-.228633E-07,0.110898E-04,-.474683E-07,
23311      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23312      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23313      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23314       DATA (DL(K),K= 3656, 3740) /
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      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23319      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23320      &0.129345E-01,0.308444E-02,0.903693E-07,0.903693E-07,0.903693E-07,
23321      &0.903693E-07,0.123538E-04,-.166230E-18,0.103598E-01,0.241354E-02,
23322      &0.155648E-06,-.205296E-06,0.154889E-06,0.155648E-06,0.267249E-04,
23323      &0.880707E-07,0.828507E-02,0.188764E-02,0.176333E-06,-.341498E-06,
23324      &0.175220E-06,0.176333E-06,0.306432E-04,0.125718E-06,0.660736E-02,
23325      &0.147304E-02,0.173444E-06,-.383695E-06,0.172215E-06,0.173444E-06,
23326      &0.280787E-04,0.135578E-06,0.525320E-02,0.114618E-02,0.158651E-06,
23327      &-.373371E-06,0.157437E-06,0.158651E-06,0.243526E-04,0.130412E-06,
23328      &0.416429E-02,0.889584E-03,0.137131E-06,-.333468E-06,0.136012E-06,
23329      &0.137131E-06,0.203463E-04,0.116115E-06,0.329102E-02,0.688580E-03,
23330      &0.113839E-06,-.280874E-06,0.112853E-06,0.113839E-06,0.161038E-04,
23331      &0.982305E-07,0.259282E-02,0.531508E-03,0.914374E-07,-.225427E-06/
23332       DATA (DL(K),K= 3741, 3825) /
23333      &0.905971E-07,0.914374E-07,0.125639E-04,0.798741E-07,0.203641E-02,
23334      &0.409120E-03,0.709595E-07,-.173123E-06,0.702607E-07,0.709595E-07,
23335      &0.979247E-05,0.624138E-07,0.159441E-02,0.314027E-03,0.532256E-07,
23336      &-.127272E-06,0.526566E-07,0.532256E-07,0.741899E-05,0.469253E-07,
23337      &0.124447E-02,0.240357E-03,0.385509E-07,-.888851E-07,0.380956E-07,
23338      &0.385509E-07,0.554070E-05,0.339174E-07,0.968328E-03,0.183454E-03,
23339      &0.267272E-07,-.580277E-07,0.263687E-07,0.267272E-07,0.420032E-05,
23340      &0.233280E-07,0.751159E-03,0.139632E-03,0.174605E-07,-.342016E-07,
23341      &0.171822E-07,0.174605E-07,0.315522E-05,0.149727E-07,0.580936E-03,
23342      &0.105986E-03,0.104515E-07,-.164567E-07,0.102383E-07,0.104515E-07,
23343      &0.230829E-05,0.863527E-08,0.447955E-03,0.802293E-04,0.531954E-08,
23344      &-.376312E-08,0.515829E-08,0.531954E-08,0.170771E-05,0.399662E-08,
23345      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23346      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23347      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23348      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23349      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23350       DATA (DL(K),K= 3826, 3910) /
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      &0.324478E-02,0.386879E-03,0.135983E-08,0.135983E-08,0.135983E-08,
23355      &0.135983E-08,0.371787E-06,-.274599E-19,0.246219E-02,0.286505E-03,
23356      &-.106852E-06,0.327611E-06,-.106589E-06,-.106852E-06,0.231631E-05,
23357      &-.107814E-06,0.186777E-02,0.212413E-03,-.161566E-06,0.492001E-06,
23358      &-.161179E-06,-.161566E-06,0.311589E-05,-.162249E-06,0.141322E-02,
23359      &0.157212E-03,-.183398E-06,0.557106E-06,-.182972E-06,-.183398E-06,
23360      &0.267943E-05,-.183884E-06,0.106518E-02,0.115892E-03,-.185231E-06,
23361      &0.562185E-06,-.184809E-06,-.185231E-06,0.203027E-05,-.185573E-06,
23362      &0.800350E-03,0.851995E-04,-.174680E-06,0.530096E-06,-.174290E-06,
23363      &-.174680E-06,0.165870E-05,-.174922E-06,0.599444E-03,0.624676E-04,
23364      &-.157644E-06,0.478420E-06,-.157300E-06,-.157644E-06,0.130112E-05,
23365      &-.157815E-06,0.447433E-03,0.456556E-04,-.137838E-06,0.418429E-06,
23366      &-.137543E-06,-.137838E-06,0.903220E-06,-.137958E-06,0.332836E-03,
23367      &0.332643E-04,-.117616E-06,0.357179E-06,-.117368E-06,-.117616E-06/
23368       DATA (DL(K),K= 3911, 3995) /
23369      &0.636187E-06,-.117699E-06,0.246754E-03,0.241622E-04,-.984560E-07,
23370      &0.299077E-06,-.982529E-07,-.984560E-07,0.481221E-06,-.985144E-07,
23371      &0.182315E-03,0.174961E-04,-.811089E-07,0.246465E-06,-.809446E-07,
23372      &-.811089E-07,0.342859E-06,-.811495E-07,0.134250E-03,0.126299E-04,
23373      &-.659052E-07,0.200354E-06,-.657742E-07,-.659052E-07,0.227840E-06,
23374      &-.659334E-07,0.985288E-04,0.908931E-05,-.529252E-07,0.160947E-06,
23375      &-.528218E-07,-.529252E-07,0.161641E-06,-.529447E-07,0.720750E-04,
23376      &0.652153E-05,-.420621E-07,0.127943E-06,-.419814E-07,-.420621E-07,
23377      &0.119540E-06,-.420756E-07,0.525538E-04,0.466527E-05,-.331141E-07,
23378      &0.100758E-06,-.330516E-07,-.331141E-07,0.808991E-07,-.331233E-07,
23379      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23380      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23381      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23382      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
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       DATA (DL(K),K= 3996, 4000) /
23387      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
23388 C
23389       ANS = 0.
23390       IF (X.GT.0.9985) RETURN
23391       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
23392 C
23393       IS  = S/DELTA+1
23394       IS1 = IS+1
23395       DO 1 L=1,25
23396          KL    = L+NDRV*25
23397          F1(L) = GF(I,IS,KL)
23398          F2(L) = GF(I,IS1,KL)
23399     1 CONTINUE
23400       A1 = DT_CKMTFF(X,F1)
23401       A2 = DT_CKMTFF(X,F2)
23402 C      A1=ALOG(A1)
23403 C      A2=ALOG(A2)
23404       S1  = (IS-1)*DELTA
23405       S2  = S1+DELTA
23406       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
23407 C      ANS=EXP(ANS)
23408       RETURN
23409       END
23410 C
23411 C
23412
23413 *$ CREATE DT_CKMTPR.FOR
23414 *COPY DT_CKMTPR
23415       SUBROUTINE DT_CKMTPR(I,NDRV,X,S,ANS)
23416 C
23417 C**********************************************************************
23418 C    Proton   - PDFs
23419 C    I   = 1, 2, 3, 4, 5, 7, 8 : xu, xd, xub, xdb, xsb, xg, xc
23420 C    ANS = PDF(I)
23421 C    This version by S. Roesler, 31.01.96
23422 C**********************************************************************
23423
23424       SAVE
23425       DIMENSION F1(25),F2(25),GF(8,20,25),DL(4000)
23426       EQUIVALENCE (GF(1,1,1),DL(1))
23427       DATA DELTA/.10/
23428 C
23429       DATA (DL(K),K=    1,   85) /
23430      &0.367759E+00,0.350609E+00,0.325356E+00,0.325356E+00,0.325356E+00,
23431      &0.325356E+00,0.533117E+01,0.138778E-16,0.427988E+00,0.409718E+00,
23432      &0.382948E+00,0.382920E+00,0.382933E+00,0.382948E+00,0.686279E+01,
23433      &0.611113E-01,0.494752E+00,0.475328E+00,0.447011E+00,0.446959E+00,
23434      &0.446984E+00,0.447011E+00,0.855688E+01,0.128659E+00,0.568248E+00,
23435      &0.547637E+00,0.517743E+00,0.517671E+00,0.517705E+00,0.517743E+00,
23436      &0.104074E+02,0.202846E+00,0.648622E+00,0.626792E+00,0.595289E+00,
23437      &0.595201E+00,0.595244E+00,0.595289E+00,0.124065E+02,0.283819E+00,
23438      &0.735974E+00,0.712890E+00,0.679748E+00,0.679648E+00,0.679696E+00,
23439      &0.679748E+00,0.145441E+02,0.371679E+00,0.830359E+00,0.805987E+00,
23440      &0.771173E+00,0.771066E+00,0.771119E+00,0.771173E+00,0.168081E+02,
23441      &0.466485E+00,0.931778E+00,0.906084E+00,0.869566E+00,0.869456E+00,
23442      &0.869511E+00,0.869566E+00,0.191850E+02,0.568240E+00,0.104018E+01,
23443      &0.101313E+01,0.974873E+00,0.974763E+00,0.974819E+00,0.974873E+00,
23444      &0.216593E+02,0.676890E+00,0.115544E+01,0.112700E+01,0.108698E+01,
23445      &0.108687E+01,0.108693E+01,0.108698E+01,0.242146E+02,0.792321E+00,
23446      &0.127738E+01,0.124751E+01,0.120570E+01,0.120560E+01,0.120565E+01/
23447       DATA (DL(K),K=   86,  170) /
23448      &0.120570E+01,0.268333E+02,0.914356E+00,0.140577E+01,0.137444E+01,
23449      &0.133079E+01,0.133070E+01,0.133075E+01,0.133079E+01,0.294970E+02,
23450      &0.104275E+01,0.154028E+01,0.150745E+01,0.146194E+01,0.146187E+01,
23451      &0.146192E+01,0.146194E+01,0.321867E+02,0.117720E+01,0.168054E+01,
23452      &0.164619E+01,0.159879E+01,0.159874E+01,0.159877E+01,0.159879E+01,
23453      &0.348836E+02,0.131732E+01,0.182613E+01,0.179020E+01,0.174088E+01,
23454      &0.174086E+01,0.174088E+01,0.174088E+01,0.375685E+02,0.146269E+01,
23455      &0.197653E+01,0.193901E+01,0.188774E+01,0.188774E+01,0.188775E+01,
23456      &0.188774E+01,0.402228E+02,0.161282E+01,0.213121E+01,0.209205E+01,
23457      &0.203880E+01,0.203884E+01,0.203884E+01,0.203880E+01,0.428285E+02,
23458      &0.176714E+01,0.228955E+01,0.224873E+01,0.219348E+01,0.219355E+01,
23459      &0.219353E+01,0.219348E+01,0.453682E+02,0.192507E+01,0.245093E+01,
23460      &0.240840E+01,0.235113E+01,0.235123E+01,0.235120E+01,0.235113E+01,
23461      &0.478258E+02,0.208597E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23462      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23463      &0.349839E+00,0.324128E+00,0.286363E+00,0.286363E+00,0.286363E+00,
23464      &0.286363E+00,0.469694E+01,0.000000E+00,0.398361E+00,0.371065E+00/
23465       DATA (DL(K),K=  171,  255) /
23466      &0.331239E+00,0.331213E+00,0.331227E+00,0.331239E+00,0.586152E+01,
23467      &0.481683E-01,0.451010E+00,0.422096E+00,0.380182E+00,0.380137E+00,
23468      &0.380161E+00,0.380182E+00,0.711349E+01,0.100378E+00,0.507782E+00,
23469      &0.477215E+00,0.433187E+00,0.433128E+00,0.433160E+00,0.433187E+00,
23470      &0.844371E+01,0.156627E+00,0.568644E+00,0.536390E+00,0.490220E+00,
23471      &0.490152E+00,0.490190E+00,0.490220E+00,0.984291E+01,0.216886E+00,
23472      &0.633517E+00,0.599543E+00,0.551204E+00,0.551133E+00,0.551174E+00,
23473      &0.551204E+00,0.113005E+02,0.281079E+00,0.702295E+00,0.666565E+00,
23474      &0.616031E+00,0.615963E+00,0.616004E+00,0.616031E+00,0.128050E+02,
23475      &0.349101E+00,0.774832E+00,0.737311E+00,0.684556E+00,0.684495E+00,
23476      &0.684535E+00,0.684556E+00,0.143447E+02,0.420809E+00,0.850945E+00,
23477      &0.811598E+00,0.756596E+00,0.756547E+00,0.756583E+00,0.756596E+00,
23478      &0.159073E+02,0.496022E+00,0.930413E+00,0.889207E+00,0.831933E+00,
23479      &0.831901E+00,0.831931E+00,0.831933E+00,0.174801E+02,0.574524E+00,
23480      &0.101298E+01,0.969882E+00,0.910312E+00,0.910301E+00,0.910324E+00,
23481      &0.910312E+00,0.190508E+02,0.656061E+00,0.109836E+01,0.105333E+01,
23482      &0.991445E+00,0.991459E+00,0.991471E+00,0.991445E+00,0.206070E+02/
23483       DATA (DL(K),K=  256,  340) /
23484      &0.740345E+00,0.118622E+01,0.113923E+01,0.107501E+01,0.107505E+01,
23485      &0.107505E+01,0.107501E+01,0.221368E+02,0.827056E+00,0.127622E+01,
23486      &0.122724E+01,0.116065E+01,0.116073E+01,0.116072E+01,0.116065E+01,
23487      &0.236287E+02,0.915845E+00,0.136797E+01,0.131696E+01,0.124800E+01,
23488      &0.124812E+01,0.124809E+01,0.124800E+01,0.250721E+02,0.100634E+01,
23489      &0.146107E+01,0.140801E+01,0.133666E+01,0.133681E+01,0.133677E+01,
23490      &0.133666E+01,0.264571E+02,0.109813E+01,0.155511E+01,0.149996E+01,
23491      &0.142621E+01,0.142641E+01,0.142634E+01,0.142621E+01,0.277747E+02,
23492      &0.119081E+01,0.164964E+01,0.159239E+01,0.151622E+01,0.151646E+01,
23493      &0.151638E+01,0.151622E+01,0.290168E+02,0.128396E+01,0.174424E+01,
23494      &0.168485E+01,0.160626E+01,0.160655E+01,0.160645E+01,0.160626E+01,
23495      &0.301765E+02,0.137713E+01,0.000000E+00,0.000000E+00,0.000000E+00,
23496      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23497      &0.345345E+00,0.306823E+00,0.250518E+00,0.250518E+00,0.250518E+00,
23498      &0.250518E+00,0.411726E+01,-.138778E-16,0.384210E+00,0.343514E+00,
23499      &0.284500E+00,0.284487E+00,0.284496E+00,0.284500E+00,0.496835E+01,
23500      &0.371582E-01,0.425419E+00,0.382518E+00,0.320782E+00,0.320762E+00/
23501       DATA (DL(K),K=  341,  425) /
23502      &0.320777E+00,0.320782E+00,0.585504E+01,0.765988E-01,0.468853E+00,
23503      &0.423717E+00,0.359246E+00,0.359226E+00,0.359243E+00,0.359246E+00,
23504      &0.676824E+01,0.118207E+00,0.514392E+00,0.466990E+00,0.399771E+00,
23505      &0.399758E+00,0.399775E+00,0.399771E+00,0.769967E+01,0.161865E+00,
23506      &0.561883E+00,0.512186E+00,0.442209E+00,0.442208E+00,0.442222E+00,
23507      &0.442209E+00,0.864071E+01,0.207426E+00,0.611162E+00,0.559140E+00,
23508      &0.486395E+00,0.486411E+00,0.486420E+00,0.486395E+00,0.958280E+01,
23509      &0.254727E+00,0.662044E+00,0.607667E+00,0.532145E+00,0.532185E+00,
23510      &0.532185E+00,0.532145E+00,0.105176E+02,0.303587E+00,0.714325E+00,
23511      &0.657566E+00,0.579261E+00,0.579328E+00,0.579318E+00,0.579261E+00,
23512      &0.114370E+02,0.353808E+00,0.767786E+00,0.708618E+00,0.627526E+00,
23513      &0.627625E+00,0.627603E+00,0.627526E+00,0.123333E+02,0.405174E+00,
23514      &0.822195E+00,0.760591E+00,0.676711E+00,0.676846E+00,0.676810E+00,
23515      &0.676711E+00,0.131994E+02,0.457458E+00,0.877307E+00,0.813242E+00,
23516      &0.726575E+00,0.726750E+00,0.726697E+00,0.726575E+00,0.140286E+02,
23517      &0.510420E+00,0.932865E+00,0.866317E+00,0.776867E+00,0.777085E+00,
23518      &0.777015E+00,0.776867E+00,0.148150E+02,0.563809E+00,0.988608E+00/
23519       DATA (DL(K),K=  426,  510) /
23520      &0.919556E+00,0.827330E+00,0.827594E+00,0.827505E+00,0.827330E+00,
23521      &0.155533E+02,0.617368E+00,0.104427E+01,0.972694E+00,0.877703E+00,
23522      &0.878016E+00,0.877907E+00,0.877703E+00,0.162391E+02,0.670837E+00,
23523      &0.109958E+01,0.102547E+01,0.927723E+00,0.928088E+00,0.927957E+00,
23524      &0.927723E+00,0.168687E+02,0.723954E+00,0.115428E+01,0.107761E+01,
23525      &0.977132E+00,0.977550E+00,0.977397E+00,0.977132E+00,0.174391E+02,
23526      &0.776458E+00,0.120809E+01,0.112886E+01,0.102567E+01,0.102615E+01,
23527      &0.102597E+01,0.102567E+01,0.179481E+02,0.828097E+00,0.126078E+01,
23528      &0.117898E+01,0.107310E+01,0.107363E+01,0.107343E+01,0.107310E+01,
23529      &0.183942E+02,0.878621E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23530      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23531      &0.357586E+00,0.299938E+00,0.216504E+00,0.216504E+00,0.216504E+00,
23532      &0.216504E+00,0.357260E+01,-.277556E-16,0.388529E+00,0.327984E+00,
23533      &0.241161E+00,0.241168E+00,0.241168E+00,0.241161E+00,0.415893E+01,
23534      &0.278429E-01,0.420472E+00,0.357015E+00,0.266823E+00,0.266844E+00,
23535      &0.266842E+00,0.266823E+00,0.474689E+01,0.566783E-01,0.453271E+00,
23536      &0.386886E+00,0.293349E+00,0.293389E+00,0.293381E+00,0.293349E+00/
23537       DATA (DL(K),K=  511,  595) /
23538      &0.532982E+01,0.863668E-01,0.486793E+00,0.417464E+00,0.320608E+00,
23539      &0.320673E+00,0.320657E+00,0.320608E+00,0.590219E+01,0.116779E+00,
23540      &0.520887E+00,0.448601E+00,0.348454E+00,0.348549E+00,0.348523E+00,
23541      &0.348454E+00,0.645868E+01,0.147773E+00,0.555403E+00,0.480149E+00,
23542      &0.376740E+00,0.376870E+00,0.376831E+00,0.376740E+00,0.699440E+01,
23543      &0.179201E+00,0.590183E+00,0.511950E+00,0.405314E+00,0.405482E+00,
23544      &0.405429E+00,0.405314E+00,0.750493E+01,0.210912E+00,0.625064E+00,
23545      &0.543845E+00,0.434019E+00,0.434229E+00,0.434159E+00,0.434019E+00,
23546      &0.798636E+01,0.242750E+00,0.659882E+00,0.575673E+00,0.462696E+00,
23547      &0.462952E+00,0.462864E+00,0.462696E+00,0.843528E+01,0.274558E+00,
23548      &0.694472E+00,0.607271E+00,0.491188E+00,0.491492E+00,0.491385E+00,
23549      &0.491188E+00,0.884885E+01,0.306178E+00,0.728669E+00,0.638478E+00,
23550      &0.519337E+00,0.519690E+00,0.519563E+00,0.519337E+00,0.922480E+01,
23551      &0.337451E+00,0.762311E+00,0.669133E+00,0.546987E+00,0.547392E+00,
23552      &0.547244E+00,0.546987E+00,0.956139E+01,0.368224E+00,0.795240E+00,
23553      &0.699084E+00,0.573988E+00,0.574447E+00,0.574277E+00,0.573988E+00,
23554      &0.985744E+01,0.398346E+00,0.827302E+00,0.728181E+00,0.600196E+00/
23555       DATA (DL(K),K=  596,  680) /
23556      &0.600710E+00,0.600518E+00,0.600196E+00,0.101123E+02,0.427671E+00,
23557      &0.858354E+00,0.756282E+00,0.625475E+00,0.626044E+00,0.625829E+00,
23558      &0.625475E+00,0.103258E+02,0.456064E+00,0.888257E+00,0.783256E+00,
23559      &0.649696E+00,0.650321E+00,0.650083E+00,0.649696E+00,0.104982E+02,
23560      &0.483395E+00,0.916887E+00,0.808981E+00,0.672742E+00,0.673422E+00,
23561      &0.673161E+00,0.672742E+00,0.106303E+02,0.509546E+00,0.944126E+00,
23562      &0.833345E+00,0.694506E+00,0.695243E+00,0.694958E+00,0.694506E+00,
23563      &0.107231E+02,0.534410E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23564      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23565      &0.390721E+00,0.304671E+00,0.182562E+00,0.182562E+00,0.182562E+00,
23566      &0.182562E+00,0.303699E+01,0.693889E-17,0.414806E+00,0.325059E+00,
23567      &0.199103E+00,0.199133E+00,0.199124E+00,0.199103E+00,0.339971E+01,
23568      &0.198528E-01,0.438929E+00,0.345508E+00,0.215797E+00,0.215862E+00,
23569      &0.215842E+00,0.215797E+00,0.374624E+01,0.398420E-01,0.462973E+00,
23570      &0.365903E+00,0.232531E+00,0.232635E+00,0.232601E+00,0.232531E+00,
23571      &0.407322E+01,0.598565E-01,0.486835E+00,0.386142E+00,0.249208E+00,
23572      &0.249352E+00,0.249304E+00,0.249208E+00,0.437817E+01,0.797987E-01/
23573       DATA (DL(K),K=  681,  765) /
23574      &0.510407E+00,0.406123E+00,0.265725E+00,0.265913E+00,0.265849E+00,
23575      &0.265725E+00,0.465901E+01,0.995694E-01,0.533588E+00,0.425746E+00,
23576      &0.281986E+00,0.282220E+00,0.282139E+00,0.281986E+00,0.491410E+01,
23577      &0.119072E+00,0.556274E+00,0.444912E+00,0.297897E+00,0.298178E+00,
23578      &0.298079E+00,0.297897E+00,0.514220E+01,0.138212E+00,0.578369E+00,
23579      &0.463528E+00,0.313366E+00,0.313696E+00,0.313578E+00,0.313366E+00,
23580      &0.534249E+01,0.156900E+00,0.599777E+00,0.481503E+00,0.328308E+00,
23581      &0.328688E+00,0.328549E+00,0.328308E+00,0.551456E+01,0.175048E+00,
23582      &0.620409E+00,0.498752E+00,0.342642E+00,0.343071E+00,0.342913E+00,
23583      &0.342642E+00,0.565833E+01,0.192575E+00,0.640181E+00,0.515196E+00,
23584      &0.356292E+00,0.356770E+00,0.356592E+00,0.356292E+00,0.577410E+01,
23585      &0.209407E+00,0.659017E+00,0.530764E+00,0.369190E+00,0.369718E+00,
23586      &0.369519E+00,0.369190E+00,0.586243E+01,0.225474E+00,0.676845E+00,
23587      &0.545389E+00,0.381275E+00,0.381852E+00,0.381633E+00,0.381275E+00,
23588      &0.592421E+01,0.240714E+00,0.693604E+00,0.559015E+00,0.392493E+00,
23589      &0.393118E+00,0.392880E+00,0.392493E+00,0.596052E+01,0.255072E+00,
23590      &0.709239E+00,0.571593E+00,0.402799E+00,0.403472E+00,0.403213E+00/
23591       DATA (DL(K),K=  766,  850) /
23592      &0.402799E+00,0.597267E+01,0.268502E+00,0.723703E+00,0.583081E+00,
23593      &0.412157E+00,0.412875E+00,0.412597E+00,0.412157E+00,0.596211E+01,
23594      &0.280966E+00,0.736960E+00,0.593447E+00,0.420536E+00,0.421299E+00,
23595      &0.421002E+00,0.420536E+00,0.593045E+01,0.292434E+00,0.748980E+00,
23596      &0.602669E+00,0.427918E+00,0.428723E+00,0.428408E+00,0.427918E+00,
23597      &0.587934E+01,0.302884E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23598      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23599      &0.448390E+00,0.320678E+00,0.146415E+00,0.146415E+00,0.146415E+00,
23600      &0.146415E+00,0.247594E+01,0.000000E+00,0.465760E+00,0.333734E+00,
23601      &0.155974E+00,0.156013E+00,0.156000E+00,0.155974E+00,0.265633E+01,
23602      &0.130329E-01,0.482525E+00,0.346293E+00,0.165233E+00,0.165311E+00,
23603      &0.165285E+00,0.165233E+00,0.281612E+01,0.257304E-01,0.498626E+00,
23604      &0.358294E+00,0.174131E+00,0.174249E+00,0.174209E+00,0.174131E+00,
23605      &0.295484E+01,0.380345E-01,0.514008E+00,0.369688E+00,0.182622E+00,
23606      &0.182779E+00,0.182724E+00,0.182622E+00,0.307242E+01,0.498976E-01,
23607      &0.528624E+00,0.380432E+00,0.190660E+00,0.190856E+00,0.190786E+00,
23608      &0.190660E+00,0.316911E+01,0.612760E-01,0.542428E+00,0.390485E+00/
23609       DATA (DL(K),K=  851,  935) /
23610      &0.198205E+00,0.198441E+00,0.198356E+00,0.198205E+00,0.324538E+01,
23611      &0.721303E-01,0.555382E+00,0.399810E+00,0.205224E+00,0.205498E+00,
23612      &0.205398E+00,0.205224E+00,0.330192E+01,0.824256E-01,0.567448E+00,
23613      &0.408377E+00,0.211687E+00,0.211997E+00,0.211882E+00,0.211687E+00,
23614      &0.333960E+01,0.921319E-01,0.578597E+00,0.416159E+00,0.217568E+00,
23615      &0.217915E+00,0.217784E+00,0.217568E+00,0.335945E+01,0.101224E+00,
23616      &0.588802E+00,0.423136E+00,0.222847E+00,0.223229E+00,0.223084E+00,
23617      &0.222847E+00,0.336262E+01,0.109681E+00,0.598043E+00,0.429293E+00,
23618      &0.227512E+00,0.227928E+00,0.227768E+00,0.227512E+00,0.335036E+01,
23619      &0.117489E+00,0.606305E+00,0.434619E+00,0.231551E+00,0.232000E+00,
23620      &0.231826E+00,0.231551E+00,0.332398E+01,0.124636E+00,0.613579E+00,
23621      &0.439110E+00,0.234962E+00,0.235442E+00,0.235254E+00,0.234962E+00,
23622      &0.328483E+01,0.131119E+00,0.619860E+00,0.442766E+00,0.237745E+00,
23623      &0.238254E+00,0.238053E+00,0.237745E+00,0.323429E+01,0.136936E+00,
23624      &0.625150E+00,0.445594E+00,0.239905E+00,0.240441E+00,0.240228E+00,
23625      &0.239905E+00,0.317371E+01,0.142091E+00,0.629453E+00,0.447603E+00,
23626      &0.241452E+00,0.242014E+00,0.241788E+00,0.241452E+00,0.310443E+01/
23627       DATA (DL(K),K=  936, 1020) /
23628      &0.146594E+00,0.632782E+00,0.448808E+00,0.242400E+00,0.242987E+00,
23629      &0.242749E+00,0.242400E+00,0.302775E+01,0.150456E+00,0.635151E+00,
23630      &0.449228E+00,0.242767E+00,0.243376E+00,0.243127E+00,0.242767E+00,
23631      &0.294491E+01,0.153694E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23632      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23633      &0.528765E+00,0.341825E+00,0.105823E+00,0.105823E+00,0.105823E+00,
23634      &0.105823E+00,0.185069E+01,-.138778E-16,0.538124E+00,0.347118E+00,
23635      &0.109762E+00,0.109780E+00,0.109774E+00,0.109762E+00,0.189644E+01,
23636      &0.738880E-02,0.546541E+00,0.351712E+00,0.113300E+00,0.113336E+00,
23637      &0.113324E+00,0.113300E+00,0.192700E+01,0.143076E-01,0.554014E+00,
23638      &0.355607E+00,0.116431E+00,0.116485E+00,0.116466E+00,0.116431E+00,
23639      &0.194356E+01,0.207515E-01,0.560546E+00,0.358805E+00,0.119150E+00,
23640      &0.119222E+00,0.119196E+00,0.119150E+00,0.194722E+01,0.267179E-01,
23641      &0.566139E+00,0.361311E+00,0.121459E+00,0.121549E+00,0.121515E+00,
23642      &0.121459E+00,0.193921E+01,0.322084E-01,0.570802E+00,0.363134E+00,
23643      &0.123359E+00,0.123467E+00,0.123426E+00,0.123359E+00,0.192071E+01,
23644      &0.372262E-01,0.574542E+00,0.364286E+00,0.124858E+00,0.124983E+00/
23645       DATA (DL(K),K= 1021, 1105) /
23646      &0.124933E+00,0.124858E+00,0.189295E+01,0.417774E-01,0.577372E+00,
23647      &0.364779E+00,0.125961E+00,0.126103E+00,0.126046E+00,0.125961E+00,
23648      &0.185710E+01,0.458703E-01,0.579307E+00,0.364629E+00,0.126681E+00,
23649      &0.126839E+00,0.126774E+00,0.126681E+00,0.181432E+01,0.495154E-01,
23650      &0.580363E+00,0.363857E+00,0.127029E+00,0.127202E+00,0.127130E+00,
23651      &0.127029E+00,0.176571E+01,0.527252E-01,0.580561E+00,0.362483E+00,
23652      &0.127020E+00,0.127208E+00,0.127128E+00,0.127020E+00,0.171231E+01,
23653      &0.555142E-01,0.579923E+00,0.360529E+00,0.126670E+00,0.126872E+00,
23654      &0.126785E+00,0.126670E+00,0.165511E+01,0.578985E-01,0.578474E+00,
23655      &0.358021E+00,0.125998E+00,0.126213E+00,0.126119E+00,0.125998E+00,
23656      &0.159501E+01,0.598958E-01,0.576241E+00,0.354987E+00,0.125022E+00,
23657      &0.125249E+00,0.125148E+00,0.125022E+00,0.153284E+01,0.615248E-01,
23658      &0.573252E+00,0.351453E+00,0.123762E+00,0.124000E+00,0.123893E+00,
23659      &0.123762E+00,0.146934E+01,0.628056E-01,0.569539E+00,0.347450E+00,
23660      &0.122240E+00,0.122488E+00,0.122375E+00,0.122240E+00,0.140517E+01,
23661      &0.637587E-01,0.565134E+00,0.343008E+00,0.120476E+00,0.120733E+00,
23662      &0.120615E+00,0.120476E+00,0.134093E+01,0.644054E-01,0.560071E+00/
23663       DATA (DL(K),K= 1106, 1190) /
23664      &0.338158E+00,0.118493E+00,0.118758E+00,0.118635E+00,0.118493E+00,
23665      &0.127712E+01,0.647671E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23666      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23667      &0.584093E+00,0.349173E+00,0.772117E-01,0.772117E-01,0.772117E-01,
23668      &0.772117E-01,0.140433E+01,0.346945E-17,0.586736E+00,0.349017E+00,
23669      &0.785355E-01,0.785519E-01,0.785448E-01,0.785355E-01,0.139434E+01,
23670      &0.447504E-02,0.588402E+00,0.348237E+00,0.795437E-01,0.795759E-01,
23671      &0.795617E-01,0.795437E-01,0.137550E+01,0.854114E-02,0.589124E+00,
23672      &0.346861E+00,0.802498E-01,0.802970E-01,0.802758E-01,0.802498E-01,
23673      &0.134918E+01,0.122148E-01,0.588930E+00,0.344912E+00,0.806656E-01,
23674      &0.807271E-01,0.806990E-01,0.806656E-01,0.131652E+01,0.155101E-01,
23675      &0.587849E+00,0.342417E+00,0.808055E-01,0.808805E-01,0.808457E-01,
23676      &0.808055E-01,0.127862E+01,0.184435E-01,0.585912E+00,0.339402E+00,
23677      &0.806843E-01,0.807718E-01,0.807306E-01,0.806843E-01,0.123648E+01,
23678      &0.210315E-01,0.583151E+00,0.335894E+00,0.803173E-01,0.804166E-01,
23679      &0.803692E-01,0.803173E-01,0.119104E+01,0.232909E-01,0.579599E+00,
23680      &0.331923E+00,0.797205E-01,0.798308E-01,0.797775E-01,0.797205E-01/
23681       DATA (DL(K),K= 1191, 1275) /
23682      &0.114317E+01,0.252394E-01,0.575288E+00,0.327516E+00,0.789107E-01,
23683      &0.790310E-01,0.789721E-01,0.789107E-01,0.109362E+01,0.268946E-01,
23684      &0.570253E+00,0.322704E+00,0.779045E-01,0.780341E-01,0.779698E-01,
23685      &0.779045E-01,0.104307E+01,0.282745E-01,0.564530E+00,0.317515E+00,
23686      &0.767190E-01,0.768570E-01,0.767878E-01,0.767190E-01,0.992143E+00,
23687      &0.293974E-01,0.558155E+00,0.311981E+00,0.753713E-01,0.755169E-01,
23688      &0.754432E-01,0.753713E-01,0.941341E+00,0.302812E-01,0.551166E+00,
23689      &0.306131E+00,0.738784E-01,0.740308E-01,0.739528E-01,0.738784E-01,
23690      &0.891113E+00,0.309441E-01,0.543599E+00,0.299995E+00,0.722571E-01,
23691      &0.724154E-01,0.723336E-01,0.722571E-01,0.841829E+00,0.314037E-01,
23692      &0.535494E+00,0.293603E+00,0.705237E-01,0.706871E-01,0.706019E-01,
23693      &0.705237E-01,0.793794E+00,0.316774E-01,0.526888E+00,0.286986E+00,
23694      &0.686941E-01,0.688619E-01,0.687736E-01,0.686941E-01,0.747249E+00,
23695      &0.317823E-01,0.517822E+00,0.280172E+00,0.667836E-01,0.669551E-01,
23696      &0.668640E-01,0.667836E-01,0.702381E+00,0.317346E-01,0.508333E+00,
23697      &0.273189E+00,0.648068E-01,0.649814E-01,0.648879E-01,0.648068E-01,
23698      &0.659330E+00,0.315501E-01,0.000000E+00,0.000000E+00,0.000000E+00/
23699       DATA (DL(K),K= 1276, 1360) /
23700      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23701      &0.622739E+00,0.340676E+00,0.509141E-01,0.509141E-01,0.509141E-01,
23702      &0.509141E-01,0.980502E+00,-.173472E-17,0.617764E+00,0.335457E+00,
23703      &0.507607E-01,0.507701E-01,0.507651E-01,0.507607E-01,0.944375E+00,
23704      &0.242386E-02,0.611957E+00,0.329837E+00,0.504236E-01,0.504417E-01,
23705      &0.504321E-01,0.504236E-01,0.905225E+00,0.455851E-02,0.605372E+00,
23706      &0.323853E+00,0.499207E-01,0.499471E-01,0.499328E-01,0.499207E-01,
23707      &0.864035E+00,0.642656E-02,0.598052E+00,0.317537E+00,0.492668E-01,
23708      &0.493008E-01,0.492822E-01,0.492668E-01,0.821557E+00,0.804638E-02,
23709      &0.590044E+00,0.310919E+00,0.484772E-01,0.485183E-01,0.484955E-01,
23710      &0.484772E-01,0.778444E+00,0.943663E-02,0.581391E+00,0.304033E+00,
23711      &0.475665E-01,0.476142E-01,0.475874E-01,0.475665E-01,0.735263E+00,
23712      &0.106150E-01,0.572137E+00,0.296908E+00,0.465487E-01,0.466024E-01,
23713      &0.465720E-01,0.465487E-01,0.692487E+00,0.115984E-01,0.562326E+00,
23714      &0.289573E+00,0.454376E-01,0.454968E-01,0.454629E-01,0.454376E-01,
23715      &0.650510E+00,0.124032E-01,0.552003E+00,0.282060E+00,0.442463E-01,
23716      &0.443103E-01,0.442733E-01,0.442463E-01,0.609652E+00,0.130451E-01/
23717       DATA (DL(K),K= 1361, 1445) /
23718      &0.541210E+00,0.274395E+00,0.429871E-01,0.430555E-01,0.430156E-01,
23719      &0.429871E-01,0.570164E+00,0.135389E-01,0.529991E+00,0.266608E+00,
23720      &0.416720E-01,0.417443E-01,0.417018E-01,0.416720E-01,0.532237E+00,
23721      &0.138989E-01,0.518389E+00,0.258725E+00,0.403123E-01,0.403879E-01,
23722      &0.403431E-01,0.403123E-01,0.496010E+00,0.141386E-01,0.506446E+00,
23723      &0.250772E+00,0.389186E-01,0.389971E-01,0.389501E-01,0.389186E-01,
23724      &0.461573E+00,0.142708E-01,0.494204E+00,0.242775E+00,0.375006E-01,
23725      &0.375815E-01,0.375327E-01,0.375006E-01,0.428979E+00,0.143074E-01,
23726      &0.481705E+00,0.234757E+00,0.360674E-01,0.361503E-01,0.361000E-01,
23727      &0.360674E-01,0.398246E+00,0.142598E-01,0.468990E+00,0.226741E+00,
23728      &0.346276E-01,0.347120E-01,0.346605E-01,0.346276E-01,0.369363E+00,
23729      &0.141385E-01,0.456098E+00,0.218750E+00,0.331887E-01,0.332743E-01,
23730      &0.332216E-01,0.331887E-01,0.342300E+00,0.139532E-01,0.443068E+00,
23731      &0.210804E+00,0.317576E-01,0.318440E-01,0.317905E-01,0.317576E-01,
23732      &0.317005E+00,0.137130E-01,0.000000E+00,0.000000E+00,0.000000E+00,
23733      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23734      &0.631458E+00,0.318714E+00,0.335640E-01,0.335640E-01,0.335640E-01/
23735       DATA (DL(K),K= 1446, 1530) /
23736      &0.335640E-01,0.686773E+00,0.346945E-17,0.620274E+00,0.310241E+00,
23737      &0.329311E-01,0.329377E-01,0.329337E-01,0.329311E-01,0.646559E+00,
23738      &0.135960E-02,0.608504E+00,0.301610E+00,0.322083E-01,0.322210E-01,
23739      &0.322133E-01,0.322083E-01,0.606503E+00,0.252820E-02,0.596205E+00,
23740      &0.292854E+00,0.314099E-01,0.314281E-01,0.314169E-01,0.314099E-01,
23741      &0.567134E+00,0.352543E-02,0.583429E+00,0.284002E+00,0.305470E-01,
23742      &0.305704E-01,0.305558E-01,0.305470E-01,0.528824E+00,0.436693E-02,
23743      &0.570223E+00,0.275080E+00,0.296307E-01,0.296586E-01,0.296411E-01,
23744      &0.296307E-01,0.491848E+00,0.506768E-02,0.556637E+00,0.266115E+00,
23745      &0.286709E-01,0.287030E-01,0.286827E-01,0.286709E-01,0.456422E+00,
23746      &0.564157E-02,0.542717E+00,0.257131E+00,0.276770E-01,0.277128E-01,
23747      &0.276900E-01,0.276770E-01,0.422697E+00,0.610148E-02,0.528511E+00,
23748      &0.248154E+00,0.266578E-01,0.266968E-01,0.266718E-01,0.266578E-01,
23749      &0.390771E+00,0.645942E-02,0.514062E+00,0.239205E+00,0.256210E-01,
23750      &0.256629E-01,0.256359E-01,0.256210E-01,0.360700E+00,0.672653E-02,
23751      &0.499417E+00,0.230307E+00,0.245741E-01,0.246185E-01,0.245896E-01,
23752      &0.245741E-01,0.332498E+00,0.691312E-02,0.484617E+00,0.221480E+00/
23753       DATA (DL(K),K= 1531, 1615) /
23754      &0.235237E-01,0.235701E-01,0.235397E-01,0.235237E-01,0.306153E+00,
23755      &0.702875E-02,0.469706E+00,0.212745E+00,0.224757E-01,0.225238E-01,
23756      &0.224921E-01,0.224757E-01,0.281624E+00,0.708222E-02,0.454725E+00,
23757      &0.204118E+00,0.214355E-01,0.214850E-01,0.214522E-01,0.214355E-01,
23758      &0.258855E+00,0.708159E-02,0.439713E+00,0.195618E+00,0.204079E-01,
23759      &0.204586E-01,0.204249E-01,0.204079E-01,0.237774E+00,0.703428E-02,
23760      &0.424709E+00,0.187259E+00,0.193972E-01,0.194486E-01,0.194142E-01,
23761      &0.193972E-01,0.218298E+00,0.694702E-02,0.409750E+00,0.179057E+00,
23762      &0.184069E-01,0.184588E-01,0.184239E-01,0.184069E-01,0.200339E+00,
23763      &0.682594E-02,0.394870E+00,0.171023E+00,0.174402E-01,0.174924E-01,
23764      &0.174571E-01,0.174402E-01,0.183804E+00,0.667657E-02,0.380104E+00,
23765      &0.163171E+00,0.164997E-01,0.165519E-01,0.165164E-01,0.164997E-01,
23766      &0.168600E+00,0.650389E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23767      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23768      &0.619056E+00,0.288873E+00,0.218554E-01,0.218554E-01,0.218554E-01,
23769      &0.218554E-01,0.477010E+00,-.867362E-17,0.602890E+00,0.278444E+00,
23770      &0.211480E-01,0.211530E-01,0.211497E-01,0.211480E-01,0.440877E+00/
23771       DATA (DL(K),K= 1616, 1700) /
23772      &0.767466E-03,0.586431E+00,0.268081E+00,0.204081E-01,0.204175E-01,
23773      &0.204113E-01,0.204081E-01,0.406417E+00,0.141432E-02,0.569736E+00,
23774      &0.257807E+00,0.196446E-01,0.196581E-01,0.196491E-01,0.196446E-01,
23775      &0.373808E+00,0.195508E-02,0.552853E+00,0.247642E+00,0.188646E-01,
23776      &0.188816E-01,0.188701E-01,0.188646E-01,0.343145E+00,0.240123E-02,
23777      &0.535829E+00,0.237603E+00,0.180743E-01,0.180945E-01,0.180808E-01,
23778      &0.180743E-01,0.314460E+00,0.276332E-02,0.518710E+00,0.227710E+00,
23779      &0.172796E-01,0.173025E-01,0.172868E-01,0.172796E-01,0.287750E+00,
23780      &0.305100E-02,0.501539E+00,0.217977E+00,0.164854E-01,0.165108E-01,
23781      &0.164933E-01,0.164854E-01,0.262983E+00,0.327305E-02,0.484360E+00,
23782      &0.208420E+00,0.156964E-01,0.157239E-01,0.157049E-01,0.156964E-01,
23783      &0.240098E+00,0.343744E-02,0.467213E+00,0.199053E+00,0.149165E-01,
23784      &0.149457E-01,0.149254E-01,0.149165E-01,0.219021E+00,0.355144E-02,
23785      &0.450140E+00,0.189889E+00,0.141493E-01,0.141800E-01,0.141586E-01,
23786      &0.141493E-01,0.199660E+00,0.362164E-02,0.433177E+00,0.180939E+00,
23787      &0.133978E-01,0.134297E-01,0.134073E-01,0.133978E-01,0.181918E+00,
23788      &0.365401E-02,0.416362E+00,0.172214E+00,0.126646E-01,0.126974E-01/
23789       DATA (DL(K),K= 1701, 1785) /
23790      &0.126742E-01,0.126646E-01,0.165692E+00,0.365394E-02,0.399729E+00,
23791      &0.163725E+00,0.119518E-01,0.119853E-01,0.119615E-01,0.119518E-01,
23792      &0.150875E+00,0.362628E-02,0.383310E+00,0.155477E+00,0.112613E-01,
23793      &0.112952E-01,0.112711E-01,0.112613E-01,0.137364E+00,0.357539E-02,
23794      &0.367138E+00,0.147479E+00,0.105945E-01,0.106287E-01,0.106042E-01,
23795      &0.105945E-01,0.125056E+00,0.350515E-02,0.351239E+00,0.139737E+00,
23796      &0.995250E-02,0.998673E-02,0.996211E-02,0.995250E-02,0.113852E+00,
23797      &0.341903E-02,0.335641E+00,0.132253E+00,0.933610E-02,0.937024E-02,
23798      &0.934557E-02,0.933610E-02,0.103659E+00,0.332009E-02,0.320367E+00,
23799      &0.125033E+00,0.874584E-02,0.877973E-02,0.875514E-02,0.874584E-02,
23800      &0.943886E-01,0.321106E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23801      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23802      &0.591114E+00,0.254807E+00,0.139531E-01,0.139531E-01,0.139531E-01,
23803      &0.139531E-01,0.326288E+00,0.000000E+00,0.571121E+00,0.243424E+00,
23804      &0.133325E-01,0.133362E-01,0.133336E-01,0.133325E-01,0.296956E+00,
23805      &0.429082E-03,0.551151E+00,0.232297E+00,0.127105E-01,0.127175E-01,
23806      &0.127126E-01,0.127105E-01,0.269811E+00,0.785137E-03,0.531253E+00/
23807       DATA (DL(K),K= 1786, 1870) /
23808      &0.221436E+00,0.120916E-01,0.121015E-01,0.120945E-01,0.120916E-01,
23809      &0.244803E+00,0.107790E-02,0.511467E+00,0.210850E+00,0.114794E-01,
23810      &0.114918E-01,0.114829E-01,0.114794E-01,0.221863E+00,0.131504E-02,
23811      &0.491833E+00,0.200545E+00,0.108767E-01,0.108913E-01,0.108808E-01,
23812      &0.108767E-01,0.200886E+00,0.150337E-02,0.472388E+00,0.190531E+00,
23813      &0.102861E-01,0.103027E-01,0.102907E-01,0.102861E-01,0.181762E+00,
23814      &0.164910E-02,0.453170E+00,0.180812E+00,0.970979E-02,0.972799E-02,
23815      &0.971477E-02,0.970979E-02,0.164371E+00,0.175777E-02,0.434213E+00,
23816      &0.171394E+00,0.914959E-02,0.916916E-02,0.915488E-02,0.914959E-02,
23817      &0.148589E+00,0.183434E-02,0.415548E+00,0.162282E+00,0.860700E-02,
23818      &0.862770E-02,0.861252E-02,0.860700E-02,0.134293E+00,0.188328E-02,
23819      &0.397208E+00,0.153479E+00,0.808323E-02,0.810484E-02,0.808891E-02,
23820      &0.808323E-02,0.121361E+00,0.190856E-02,0.379220E+00,0.144989E+00,
23821      &0.757922E-02,0.760152E-02,0.758501E-02,0.757922E-02,0.109676E+00,
23822      &0.191374E-02,0.361611E+00,0.136811E+00,0.709565E-02,0.711846E-02,
23823      &0.710150E-02,0.709565E-02,0.991261E-01,0.190199E-02,0.344406E+00,
23824      &0.128948E+00,0.663300E-02,0.665614E-02,0.663885E-02,0.663300E-02/
23825       DATA (DL(K),K= 1871, 1955) /
23826      &0.896059E-01,0.187610E-02,0.327627E+00,0.121398E+00,0.619152E-02,
23827      &0.621484E-02,0.619734E-02,0.619152E-02,0.810177E-01,0.183856E-02,
23828      &0.311292E+00,0.114161E+00,0.577130E-02,0.579466E-02,0.577706E-02,
23829      &0.577130E-02,0.732709E-01,0.179155E-02,0.295421E+00,0.107235E+00,
23830      &0.537228E-02,0.539554E-02,0.537794E-02,0.537228E-02,0.662824E-01,
23831      &0.173700E-02,0.280026E+00,0.100616E+00,0.499423E-02,0.501728E-02,
23832      &0.499977E-02,0.499423E-02,0.599766E-01,0.167658E-02,0.265121E+00,
23833      &0.943000E-01,0.463683E-02,0.465958E-02,0.464223E-02,0.463683E-02,
23834      &0.542848E-01,0.161174E-02,0.000000E+00,0.000000E+00,0.000000E+00,
23835      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23836      &0.551659E+00,0.219084E+00,0.867977E-02,0.867977E-02,0.867977E-02,
23837      &0.867977E-02,0.218587E+00,-.173472E-16,0.528947E+00,0.207536E+00,
23838      &0.819621E-02,0.819909E-02,0.819696E-02,0.819621E-02,0.196367E+00,
23839      &0.234843E-03,0.506575E+00,0.196391E+00,0.772540E-02,0.773082E-02,
23840      &0.772680E-02,0.772540E-02,0.176280E+00,0.427503E-03,0.484579E+00,
23841      &0.185646E+00,0.726876E-02,0.727639E-02,0.727069E-02,0.726876E-02,
23842      &0.158158E+00,0.583933E-03,0.462988E+00,0.175298E+00,0.682746E-02/
23843       DATA (DL(K),K= 1956, 2040) /
23844      &0.683702E-02,0.682985E-02,0.682746E-02,0.141851E+00,0.708874E-03,
23845      &0.441830E+00,0.165345E+00,0.640226E-02,0.641347E-02,0.640502E-02,
23846      &0.640226E-02,0.127203E+00,0.806409E-03,0.421129E+00,0.155783E+00,
23847      &0.599380E-02,0.600641E-02,0.599686E-02,0.599380E-02,0.114065E+00,
23848      &0.880249E-03,0.400912E+00,0.146609E+00,0.560252E-02,0.561629E-02,
23849      &0.560581E-02,0.560252E-02,0.102296E+00,0.933676E-03,0.381199E+00,
23850      &0.137819E+00,0.522870E-02,0.524342E-02,0.523217E-02,0.522870E-02,
23851      &0.917608E-01,0.969607E-03,0.362011E+00,0.129407E+00,0.487247E-02,
23852      &0.488796E-02,0.487607E-02,0.487247E-02,0.823356E-01,0.990632E-03,
23853      &0.343367E+00,0.121370E+00,0.453385E-02,0.454992E-02,0.453753E-02,
23854      &0.453385E-02,0.739054E-01,0.999042E-03,0.325282E+00,0.113700E+00,
23855      &0.421272E-02,0.422921E-02,0.421644E-02,0.421272E-02,0.663651E-01,
23856      &0.996863E-03,0.307770E+00,0.106393E+00,0.390887E-02,0.392563E-02,
23857      &0.391260E-02,0.390887E-02,0.596195E-01,0.985881E-03,0.290841E+00,
23858      &0.994399E-01,0.362199E-02,0.363889E-02,0.362570E-02,0.362199E-02,
23859      &0.535826E-01,0.967664E-03,0.274506E+00,0.928343E-01,0.335170E-02,
23860      &0.336862E-02,0.335536E-02,0.335170E-02,0.481769E-01,0.943587E-03/
23861       DATA (DL(K),K= 2041, 2125) /
23862      &0.258771E+00,0.865679E-01,0.309756E-02,0.311439E-02,0.310114E-02,
23863      &0.309756E-02,0.433336E-01,0.914850E-03,0.243639E+00,0.806321E-01,
23864      &0.285905E-02,0.287571E-02,0.286255E-02,0.285905E-02,0.389912E-01,
23865      &0.882497E-03,0.229113E+00,0.750177E-01,0.263565E-02,0.265205E-02,
23866      &0.263905E-02,0.263565E-02,0.350948E-01,0.847432E-03,0.215193E+00,
23867      &0.697152E-01,0.242677E-02,0.244285E-02,0.243005E-02,0.242677E-02,
23868      &0.315960E-01,0.810432E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23869      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23870      &0.503850E+00,0.183581E+00,0.522815E-02,0.522815E-02,0.522815E-02,
23871      &0.522815E-02,0.142635E+00,0.123599E-16,0.479478E+00,0.172477E+00,
23872      &0.488093E-02,0.488328E-02,0.488147E-02,0.488093E-02,0.126767E+00,
23873      &0.124505E-03,0.455750E+00,0.161879E+00,0.455054E-02,0.455493E-02,
23874      &0.455153E-02,0.455054E-02,0.112695E+00,0.225968E-03,0.432681E+00,
23875      &0.151771E+00,0.423664E-02,0.424278E-02,0.423800E-02,0.423664E-02,
23876      &0.100212E+00,0.307702E-03,0.410286E+00,0.142140E+00,0.393907E-02,
23877      &0.394671E-02,0.394073E-02,0.393907E-02,0.891488E-01,0.372395E-03,
23878      &0.388577E+00,0.132974E+00,0.365743E-02,0.366634E-02,0.365934E-02/
23879       DATA (DL(K),K= 2126, 2210) /
23880      &0.365743E-02,0.793490E-01,0.422302E-03,0.367563E+00,0.124259E+00,
23881      &0.339138E-02,0.340133E-02,0.339347E-02,0.339138E-02,0.706688E-01,
23882      &0.459484E-03,0.347256E+00,0.115984E+00,0.314049E-02,0.315129E-02,
23883      &0.314273E-02,0.314049E-02,0.629792E-01,0.485762E-03,0.327660E+00,
23884      &0.108136E+00,0.290433E-02,0.291580E-02,0.290667E-02,0.290433E-02,
23885      &0.561642E-01,0.502744E-03,0.308782E+00,0.100701E+00,0.268243E-02,
23886      &0.269440E-02,0.268483E-02,0.268243E-02,0.501207E-01,0.511853E-03,
23887      &0.290625E+00,0.936693E-01,0.247429E-02,0.248663E-02,0.247672E-02,
23888      &0.247429E-02,0.447569E-01,0.514346E-03,0.273189E+00,0.870261E-01,
23889      &0.227939E-02,0.229197E-02,0.228184E-02,0.227939E-02,0.399920E-01,
23890      &0.511328E-03,0.256475E+00,0.807592E-01,0.209722E-02,0.210991E-02,
23891      &0.209965E-02,0.209722E-02,0.357547E-01,0.503769E-03,0.240478E+00,
23892      &0.748555E-01,0.192721E-02,0.193992E-02,0.192961E-02,0.192721E-02,
23893      &0.319825E-01,0.492518E-03,0.225194E+00,0.693019E-01,0.176883E-02,
23894      &0.178147E-02,0.177117E-02,0.176883E-02,0.286209E-01,0.478318E-03,
23895      &0.210615E+00,0.640851E-01,0.162151E-02,0.163400E-02,0.162379E-02,
23896      &0.162151E-02,0.256219E-01,0.461813E-03,0.196733E+00,0.591917E-01/
23897       DATA (DL(K),K= 2211, 2295) /
23898      &0.148471E-02,0.149698E-02,0.148691E-02,0.148471E-02,0.229436E-01,
23899      &0.443561E-03,0.183536E+00,0.546085E-01,0.135786E-02,0.136986E-02,
23900      &0.135998E-02,0.135786E-02,0.205496E-01,0.424043E-03,0.171011E+00,
23901      &0.503219E-01,0.124042E-02,0.125211E-02,0.124246E-02,0.124042E-02,
23902      &0.184079E-01,0.403672E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23903      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23904      &0.450310E+00,0.149685E+00,0.302765E-02,0.302765E-02,0.302765E-02,
23905      &0.302765E-02,0.901099E-01,-.108420E-17,0.425282E+00,0.139479E+00,
23906      &0.279499E-02,0.279691E-02,0.279537E-02,0.279499E-02,0.794239E-01,
23907      &0.632140E-04,0.401169E+00,0.129837E+00,0.257801E-02,0.258157E-02,
23908      &0.257870E-02,0.257801E-02,0.700941E-01,0.114711E-03,0.377966E+00,
23909      &0.120733E+00,0.237556E-02,0.238052E-02,0.237650E-02,0.237556E-02,
23910      &0.619270E-01,0.156107E-03,0.355668E+00,0.112145E+00,0.218688E-02,
23911      &0.219301E-02,0.218802E-02,0.218688E-02,0.547717E-01,0.188777E-03,
23912      &0.334269E+00,0.104052E+00,0.201113E-02,0.201823E-02,0.201243E-02,
23913      &0.201113E-02,0.484974E-01,0.213848E-03,0.313762E+00,0.964335E-01,
23914      &0.184758E-02,0.185546E-02,0.184900E-02,0.184758E-02,0.429879E-01/
23915       DATA (DL(K),K= 2296, 2380) /
23916      &0.232367E-03,0.294139E+00,0.892696E-01,0.169553E-02,0.170402E-02,
23917      &0.169703E-02,0.169553E-02,0.381432E-01,0.245270E-03,0.275389E+00,
23918      &0.825414E-01,0.155431E-02,0.156326E-02,0.155586E-02,0.155431E-02,
23919      &0.338762E-01,0.253383E-03,0.257502E+00,0.762303E-01,0.142329E-02,
23920      &0.143258E-02,0.142487E-02,0.142329E-02,0.301119E-01,0.257441E-03,
23921      &0.240464E+00,0.703180E-01,0.130188E-02,0.131138E-02,0.130347E-02,
23922      &0.130188E-02,0.267853E-01,0.258098E-03,0.224262E+00,0.647867E-01,
23923      &0.118950E-02,0.119912E-02,0.119108E-02,0.118950E-02,0.238409E-01,
23924      &0.255929E-03,0.208879E+00,0.596190E-01,0.108562E-02,0.109526E-02,
23925      &0.108717E-02,0.108562E-02,0.212308E-01,0.251442E-03,0.194298E+00,
23926      &0.547975E-01,0.989698E-03,0.999283E-03,0.991221E-03,0.989698E-03,
23927      &0.189136E-01,0.245082E-03,0.180499E+00,0.503054E-01,0.901248E-03,
23928      &0.910711E-03,0.902726E-03,0.901248E-03,0.168537E-01,0.237238E-03,
23929      &0.167463E+00,0.461263E-01,0.819789E-03,0.829074E-03,0.821215E-03,
23930      &0.819789E-03,0.150206E-01,0.228250E-03,0.155167E+00,0.422438E-01,
23931      &0.744866E-03,0.753925E-03,0.746234E-03,0.744866E-03,0.133878E-01,
23932      &0.218412E-03,0.143590E+00,0.386421E-01,0.676043E-03,0.684836E-03/
23933       DATA (DL(K),K= 2381, 2465) /
23934      &0.677349E-03,0.676043E-03,0.119320E-01,0.207976E-03,0.132706E+00,
23935      &0.353058E-01,0.612907E-03,0.621403E-03,0.614147E-03,0.612907E-03,
23936      &0.106334E-01,0.197159E-03,0.000000E+00,0.000000E+00,0.000000E+00,
23937      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23938      &0.393307E+00,0.118409E+00,0.167124E-02,0.167124E-02,0.167124E-02,
23939      &0.167124E-02,0.547140E-01,0.433681E-17,0.368555E+00,0.109414E+00,
23940      &0.152547E-02,0.152705E-02,0.152573E-02,0.152547E-02,0.479708E-01,
23941      &0.303147E-04,0.344946E+00,0.101001E+00,0.139202E-02,0.139494E-02,
23942      &0.139249E-02,0.139202E-02,0.421517E-01,0.552185E-04,0.322450E+00,
23943      &0.931345E-01,0.126960E-02,0.127363E-02,0.127024E-02,0.126960E-02,
23944      &0.371043E-01,0.753524E-04,0.301043E+00,0.857854E-01,0.115731E-02,
23945      &0.116225E-02,0.115808E-02,0.115731E-02,0.327131E-01,0.913172E-04,
23946      &0.280698E+00,0.789267E-01,0.105427E-02,0.105995E-02,0.105514E-02,
23947      &0.105427E-02,0.288844E-01,0.103605E-03,0.261390E+00,0.725323E-01,
23948      &0.959726E-03,0.965979E-03,0.960659E-03,0.959726E-03,0.255366E-01,
23949      &0.112688E-03,0.243091E+00,0.665774E-01,0.872987E-03,0.879676E-03,
23950      &0.873966E-03,0.872987E-03,0.226017E-01,0.119000E-03,0.225775E+00/
23951       DATA (DL(K),K= 2466, 2550) /
23952      &0.610385E-01,0.793435E-03,0.800438E-03,0.794441E-03,0.793435E-03,
23953      &0.200219E-01,0.122931E-03,0.209414E+00,0.558928E-01,0.720508E-03,
23954      &0.727716E-03,0.721524E-03,0.720508E-03,0.177490E-01,0.124835E-03,
23955      &0.193979E+00,0.511187E-01,0.653691E-03,0.661011E-03,0.654703E-03,
23956      &0.653691E-03,0.157425E-01,0.125031E-03,0.179441E+00,0.466950E-01,
23957      &0.592513E-03,0.599863E-03,0.593511E-03,0.592513E-03,0.139674E-01,
23958      &0.123805E-03,0.165770E+00,0.426018E-01,0.536539E-03,0.543850E-03,
23959      &0.537513E-03,0.536539E-03,0.123945E-01,0.121411E-03,0.152935E+00,
23960      &0.388195E-01,0.485370E-03,0.492584E-03,0.486314E-03,0.485370E-03,
23961      &0.109993E-01,0.118076E-03,0.140905E+00,0.353295E-01,0.438636E-03,
23962      &0.445702E-03,0.439543E-03,0.438636E-03,0.976027E-02,0.113999E-03,
23963      &0.129648E+00,0.321137E-01,0.395992E-03,0.402871E-03,0.396859E-03,
23964      &0.395992E-03,0.865895E-02,0.109353E-03,0.119131E+00,0.291550E-01,
23965      &0.357120E-03,0.363779E-03,0.357945E-03,0.357120E-03,0.767960E-02,
23966      &0.104292E-03,0.109323E+00,0.264366E-01,0.321725E-03,0.328139E-03,
23967      &0.322505E-03,0.321725E-03,0.680866E-02,0.989468E-04,0.100191E+00,
23968      &0.239428E-01,0.289531E-03,0.295679E-03,0.290266E-03,0.289531E-03/
23969       DATA (DL(K),K= 2551, 2635) /
23970      &0.603390E-02,0.934295E-04,0.000000E+00,0.000000E+00,0.000000E+00,
23971      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
23972      &0.334851E+00,0.904666E-01,0.869706E-03,0.869706E-03,0.869706E-03,
23973      &0.869706E-03,0.316365E-01,-.311708E-17,0.311223E+00,0.828706E-01,
23974      &0.784673E-03,0.785968E-03,0.784847E-03,0.784673E-03,0.277037E-01,
23975      &0.134749E-04,0.288910E+00,0.758361E-01,0.708234E-03,0.710597E-03,
23976      &0.708543E-03,0.708234E-03,0.243298E-01,0.247881E-04,0.267855E+00,
23977      &0.693222E-01,0.639256E-03,0.642491E-03,0.639671E-03,0.639256E-03,
23978      &0.214125E-01,0.340882E-04,0.248015E+00,0.632964E-01,0.576953E-03,
23979      &0.580887E-03,0.577448E-03,0.576953E-03,0.188764E-01,0.415701E-04,
23980      &0.229343E+00,0.577274E-01,0.520615E-03,0.525096E-03,0.521167E-03,
23981      &0.520615E-03,0.166642E-01,0.474027E-04,0.211794E+00,0.525860E-01,
23982      &0.469624E-03,0.474520E-03,0.470215E-03,0.469624E-03,0.147265E-01,
23983      &0.517615E-04,0.195325E+00,0.478447E-01,0.423445E-03,0.428640E-03,
23984      &0.424060E-03,0.423445E-03,0.130234E-01,0.548213E-04,0.179891E+00,
23985      &0.434776E-01,0.381606E-03,0.387001E-03,0.382232E-03,0.381606E-03,
23986      &0.115226E-01,0.567474E-04,0.165449E+00,0.394601E-01,0.343691E-03/
23987       DATA (DL(K),K= 2636, 2720) /
23988      &0.349200E-03,0.344317E-03,0.343691E-03,0.101965E-01,0.576952E-04,
23989      &0.151958E+00,0.357691E-01,0.309329E-03,0.314879E-03,0.309948E-03,
23990      &0.309329E-03,0.902217E-02,0.578101E-04,0.139374E+00,0.323826E-01,
23991      &0.278192E-03,0.283721E-03,0.278796E-03,0.278192E-03,0.798131E-02,
23992      &0.572266E-04,0.127655E+00,0.292797E-01,0.249984E-03,0.255440E-03,
23993      &0.250569E-03,0.249984E-03,0.705796E-02,0.560672E-04,0.116760E+00,
23994      &0.264406E-01,0.224440E-03,0.229782E-03,0.225002E-03,0.224440E-03,
23995      &0.623793E-02,0.544420E-04,0.106647E+00,0.238467E-01,0.201321E-03,
23996      &0.206513E-03,0.201856E-03,0.201321E-03,0.550962E-02,0.524504E-04,
23997      &0.972762E-01,0.214802E-01,0.180411E-03,0.185425E-03,0.180918E-03,
23998      &0.180411E-03,0.486321E-02,0.501804E-04,0.886073E-01,0.193242E-01,
23999      &0.161512E-03,0.166328E-03,0.161990E-03,0.161512E-03,0.428946E-02,
24000      &0.477087E-04,0.806013E-01,0.173629E-01,0.144446E-03,0.149048E-03,
24001      &0.144894E-03,0.144446E-03,0.378030E-02,0.451020E-04,0.732197E-01,
24002      &0.155814E-01,0.129049E-03,0.133425E-03,0.129467E-03,0.129049E-03,
24003      &0.332897E-02,0.424179E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24004      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24005       DATA (DL(K),K= 2721, 2805) /
24006      &0.276761E+00,0.663170E-01,0.420483E-03,0.420483E-03,0.420483E-03,
24007      &0.420483E-03,0.172075E-01,0.418773E-17,0.255003E+00,0.601925E-01,
24008      &0.374768E-03,0.375776E-03,0.374876E-03,0.374768E-03,0.151410E-01,
24009      &0.540038E-05,0.234664E+00,0.545789E-01,0.334420E-03,0.336252E-03,
24010      &0.334612E-03,0.334420E-03,0.133594E-01,0.101360E-04,0.215665E+00,
24011      &0.494328E-01,0.298611E-03,0.301108E-03,0.298867E-03,0.298611E-03,
24012      &0.118079E-01,0.141555E-04,0.197941E+00,0.447203E-01,0.266766E-03,
24013      &0.269787E-03,0.267068E-03,0.266766E-03,0.104461E-01,0.174750E-04,
24014      &0.181428E+00,0.404089E-01,0.238391E-03,0.241815E-03,0.238726E-03,
24015      &0.238391E-03,0.924609E-02,0.201244E-04,0.166064E+00,0.364687E-01,
24016      &0.213061E-03,0.216782E-03,0.213417E-03,0.213061E-03,0.818507E-02,
24017      &0.221467E-04,0.151790E+00,0.328719E-01,0.190418E-03,0.194343E-03,
24018      &0.190785E-03,0.190418E-03,0.724366E-02,0.235974E-04,0.138548E+00,
24019      &0.295925E-01,0.170150E-03,0.174202E-03,0.170521E-03,0.170150E-03,
24020      &0.640614E-02,0.245354E-04,0.126282E+00,0.266063E-01,0.151991E-03,
24021      &0.156104E-03,0.152359E-03,0.151991E-03,0.566089E-02,0.250221E-04,
24022      &0.114939E+00,0.238907E-01,0.135710E-03,0.139827E-03,0.136071E-03/
24023       DATA (DL(K),K= 2806, 2890) /
24024      &0.135710E-03,0.499773E-02,0.251191E-04,0.104465E+00,0.214245E-01,
24025      &0.121106E-03,0.125180E-03,0.121455E-03,0.121106E-03,0.440691E-02,
24026      &0.248850E-04,0.948101E-01,0.191879E-01,0.108002E-03,0.111994E-03,
24027      &0.108337E-03,0.108002E-03,0.388094E-02,0.243760E-04,0.859247E-01,
24028      &0.171625E-01,0.962435E-04,0.100124E-03,0.965624E-04,0.962435E-04,
24029      &0.341379E-02,0.236445E-04,0.777613E-01,0.153309E-01,0.856948E-04,
24030      &0.894394E-04,0.859960E-04,0.856948E-04,0.299910E-02,0.227378E-04,
24031      &0.702736E-01,0.136770E-01,0.762337E-04,0.798235E-04,0.765166E-04,
24032      &0.762337E-04,0.263116E-02,0.216984E-04,0.634174E-01,0.121859E-01,
24033      &0.677528E-04,0.711742E-04,0.680169E-04,0.677528E-04,0.230551E-02,
24034      &0.205642E-04,0.571500E-01,0.108434E-01,0.601554E-04,0.633990E-04,
24035      &0.604008E-04,0.601554E-04,0.201791E-02,0.193681E-04,0.514305E-01,
24036      &0.963651E-02,0.533545E-04,0.564148E-04,0.535814E-04,0.533545E-04,
24037      &0.176404E-02,0.181381E-04,0.000000E+00,0.000000E+00,0.000000E+00,
24038      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24039      &0.220700E+00,0.461964E-01,0.185072E-03,0.185072E-03,0.185072E-03,
24040      &0.185072E-03,0.865568E-02,-.294090E-17,0.201438E+00,0.415162E-01/
24041       DATA (DL(K),K= 2891, 2975) /
24042      &0.162774E-03,0.163610E-03,0.162842E-03,0.162774E-03,0.772611E-02,
24043      &0.184134E-05,0.183625E+00,0.372730E-01,0.143469E-03,0.144974E-03,
24044      &0.143588E-03,0.143469E-03,0.690038E-02,0.359959E-05,0.167162E+00,
24045      &0.334245E-01,0.126634E-03,0.128666E-03,0.126791E-03,0.126634E-03,
24046      &0.616000E-02,0.518075E-05,0.151966E+00,0.299378E-01,0.111904E-03,
24047      &0.114340E-03,0.112088E-03,0.111904E-03,0.549219E-02,0.654232E-05,
24048      &0.137959E+00,0.267821E-01,0.989836E-04,0.101716E-03,0.991845E-04,
24049      &0.989836E-04,0.488896E-02,0.767008E-05,0.125065E+00,0.239289E-01,
24050      &0.876157E-04,0.905559E-04,0.878269E-04,0.876157E-04,0.434253E-02,
24051      &0.855860E-05,0.113213E+00,0.213524E-01,0.775899E-04,0.806611E-04,
24052      &0.778055E-04,0.775899E-04,0.384886E-02,0.921640E-05,0.102335E+00,
24053      &0.190285E-01,0.687292E-04,0.718676E-04,0.689446E-04,0.687292E-04,
24054      &0.340422E-02,0.965961E-05,0.923671E-01,0.169353E-01,0.608829E-04,
24055      &0.640353E-04,0.610944E-04,0.608829E-04,0.300332E-02,0.990752E-05,
24056      &0.832476E-01,0.150523E-01,0.539242E-04,0.570473E-04,0.541291E-04,
24057      &0.539242E-04,0.264288E-02,0.998320E-05,0.749179E-01,0.133608E-01,
24058      &0.477459E-04,0.508046E-04,0.479422E-04,0.477459E-04,0.232088E-02/
24059       DATA (DL(K),K= 2976, 3060) /
24060      &0.991147E-05,0.673221E-01,0.118435E-01,0.422554E-04,0.452220E-04,
24061      &0.424417E-04,0.422554E-04,0.203376E-02,0.971603E-05,0.604073E-01,
24062      &0.104845E-01,0.373730E-04,0.402263E-04,0.375483E-04,0.373730E-04,
24063      &0.177791E-02,0.941959E-05,0.541231E-01,0.926900E-02,0.330304E-04,
24064      &0.357544E-04,0.331943E-04,0.330304E-04,0.155117E-02,0.904408E-05,
24065      &0.484216E-01,0.818347E-02,0.291681E-04,0.317517E-04,0.293202E-04,
24066      &0.291681E-04,0.135108E-02,0.860921E-05,0.432578E-01,0.721549E-02,
24067      &0.257333E-04,0.281694E-04,0.258738E-04,0.257333E-04,0.117463E-02,
24068      &0.813214E-05,0.385889E-01,0.635362E-02,0.226802E-04,0.249648E-04,
24069      &0.228093E-04,0.226802E-04,0.101941E-02,0.762814E-05,0.343746E-01,
24070      &0.558739E-02,0.199682E-04,0.221003E-04,0.200863E-04,0.199682E-04,
24071      &0.883469E-03,0.711035E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24072      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24073      &0.168205E+00,0.301419E-01,0.719932E-04,0.719932E-04,0.719932E-04,
24074      &0.719932E-04,0.392825E-02,-.205998E-17,0.151922E+00,0.267932E-01,
24075      &0.623634E-04,0.630456E-04,0.624028E-04,0.623634E-04,0.361412E-02,
24076      &0.457084E-06,0.137042E+00,0.237932E-01,0.541981E-04,0.554098E-04/
24077       DATA (DL(K),K= 3061, 3145) /
24078      &0.542663E-04,0.541981E-04,0.330342E-02,0.989813E-06,0.123446E+00,
24079      &0.211038E-01,0.472163E-04,0.488314E-04,0.473050E-04,0.472163E-04,
24080      &0.300140E-02,0.152631E-05,0.111042E+00,0.186954E-01,0.412159E-04,
24081      &0.431273E-04,0.413184E-04,0.412159E-04,0.270826E-02,0.202092E-05,
24082      &0.997395E-01,0.165410E-01,0.360433E-04,0.381615E-04,0.361542E-04,
24083      &0.360433E-04,0.242968E-02,0.245400E-05,0.894558E-01,0.146159E-01,
24084      &0.315670E-04,0.338178E-04,0.316822E-04,0.315670E-04,0.216928E-02,
24085      &0.281218E-05,0.801130E-01,0.128978E-01,0.276779E-04,0.300002E-04,
24086      &0.277940E-04,0.276779E-04,0.192603E-02,0.308878E-05,0.716379E-01,
24087      &0.113663E-01,0.242878E-04,0.266317E-04,0.244024E-04,0.242878E-04,
24088      &0.170100E-02,0.328451E-05,0.639623E-01,0.100031E-01,0.213246E-04,
24089      &0.236502E-04,0.214357E-04,0.213246E-04,0.149649E-02,0.340483E-05,
24090      &0.570222E-01,0.879131E-02,0.187277E-04,0.210033E-04,0.188341E-04,
24091      &0.187277E-04,0.131163E-02,0.345656E-05,0.507574E-01,0.771565E-02,
24092      &0.164465E-04,0.186476E-04,0.165471E-04,0.164465E-04,0.114469E-02,
24093      &0.344782E-05,0.451118E-01,0.676223E-02,0.144396E-04,0.165480E-04,
24094      &0.145339E-04,0.144396E-04,0.995649E-03,0.338831E-05,0.400330E-01/
24095       DATA (DL(K),K= 3146, 3230) /
24096      &0.591841E-02,0.126720E-04,0.146744E-04,0.127597E-04,0.126720E-04,
24097      &0.863829E-03,0.328754E-05,0.354720E-01,0.517273E-02,0.111137E-04,
24098      &0.130013E-04,0.111946E-04,0.111137E-04,0.747293E-03,0.315403E-05,
24099      &0.313830E-01,0.451477E-02,0.973915E-05,0.115067E-04,0.981339E-05,
24100      &0.973915E-05,0.644664E-03,0.299600E-05,0.277237E-01,0.393511E-02,
24101      &0.852687E-05,0.101721E-04,0.859457E-05,0.852687E-05,0.555034E-03,
24102      &0.282099E-05,0.244545E-01,0.342521E-02,0.745784E-05,0.898076E-05,
24103      &0.751926E-05,0.745784E-05,0.476998E-03,0.263530E-05,0.215390E-01,
24104      &0.297737E-02,0.651555E-05,0.791817E-05,0.657100E-05,0.651555E-05,
24105      &0.409096E-03,0.244427E-05,0.000000E+00,0.000000E+00,0.000000E+00,
24106      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24107      &0.120694E+00,0.180081E-01,0.236444E-04,0.236444E-04,0.236444E-04,
24108      &0.236444E-04,0.154817E-02,0.416656E-17,0.107713E+00,0.158098E-01,
24109      &0.200945E-04,0.206098E-04,0.201146E-04,0.200945E-04,0.151249E-02,
24110      &0.192118E-07,0.960063E-01,0.138667E-01,0.171552E-04,0.180593E-04,
24111      &0.171894E-04,0.171552E-04,0.143574E-02,0.116516E-06,0.854477E-01,
24112      &0.121473E-01,0.146986E-04,0.158894E-04,0.147425E-04,0.146986E-04/
24113       DATA (DL(K),K= 3231, 3315) /
24114      &0.133744E-02,0.251060E-06,0.759386E-01,0.106275E-01,0.126329E-04,
24115      &0.140252E-04,0.126830E-04,0.126329E-04,0.122900E-02,0.395272E-06,
24116      &0.673865E-01,0.928577E-02,0.108901E-04,0.124142E-04,0.109436E-04,
24117      &0.108901E-04,0.111367E-02,0.535145E-06,0.597062E-01,0.810254E-02,
24118      &0.941160E-05,0.110108E-04,0.946648E-05,0.941160E-05,0.996785E-03,
24119      &0.659421E-06,0.528194E-01,0.706039E-02,0.815165E-05,0.978016E-05,
24120      &0.820627E-05,0.815165E-05,0.885152E-03,0.762600E-06,0.466540E-01,
24121      &0.614371E-02,0.707299E-05,0.869464E-05,0.712616E-05,0.707299E-05,
24122      &0.780484E-03,0.842072E-06,0.411433E-01,0.533850E-02,0.614470E-05,
24123      &0.773135E-05,0.619559E-05,0.614470E-05,0.682563E-03,0.896683E-06,
24124      &0.362261E-01,0.463223E-02,0.534297E-05,0.687330E-05,0.539102E-05,
24125      &0.534297E-05,0.593317E-03,0.928176E-06,0.318459E-01,0.401364E-02,
24126      &0.464848E-05,0.610690E-05,0.469333E-05,0.464848E-05,0.513720E-03,
24127      &0.939174E-06,0.279510E-01,0.347266E-02,0.404483E-05,0.542054E-05,
24128      &0.408628E-05,0.404483E-05,0.442713E-03,0.932117E-06,0.244935E-01,
24129      &0.300029E-02,0.351893E-05,0.480507E-05,0.355692E-05,0.351893E-05,
24130      &0.379744E-03,0.910085E-06,0.214299E-01,0.258845E-02,0.306021E-05/
24131       DATA (DL(K),K= 3316, 3400) /
24132      &0.425313E-05,0.309476E-05,0.306021E-05,0.324785E-03,0.876365E-06,
24133      &0.187200E-01,0.222996E-02,0.265958E-05,0.375823E-05,0.269081E-05,
24134      &0.265958E-05,0.277080E-03,0.833755E-06,0.163273E-01,0.191840E-02,
24135      &0.230942E-05,0.331477E-05,0.233747E-05,0.230942E-05,0.235661E-03,
24136      &0.784780E-06,0.142185E-01,0.164805E-02,0.200337E-05,0.291797E-05,
24137      &0.202844E-05,0.200337E-05,0.199949E-03,0.731774E-06,0.123631E-01,
24138      &0.141382E-02,0.173596E-05,0.256351E-05,0.175824E-05,0.173596E-05,
24139      &0.169376E-03,0.676674E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24140      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24141      &0.794823E-01,0.948208E-02,0.607312E-05,0.607312E-05,0.607312E-05,
24142      &0.607312E-05,0.497062E-03,-.140523E-17,0.699344E-01,0.820355E-02,
24143      &0.500852E-05,0.538347E-05,0.501731E-05,0.500852E-05,0.542262E-03,
24144      &-.714686E-07,0.614560E-01,0.709106E-02,0.415227E-05,0.479898E-05,
24145      &0.416702E-05,0.415227E-05,0.549985E-03,-.960102E-07,0.539240E-01,
24146      &0.612155E-02,0.345977E-05,0.429563E-05,0.347839E-05,0.345977E-05,
24147      &0.531288E-03,-.894946E-07,0.472426E-01,0.527757E-02,0.289508E-05,
24148      &0.385164E-05,0.291595E-05,0.289508E-05,0.495120E-03,-.668594E-07/
24149       DATA (DL(K),K= 3401, 3485) /
24150      &0.413245E-01,0.454380E-02,0.243524E-05,0.345851E-05,0.245713E-05,
24151      &0.243524E-05,0.452156E-03,-.338861E-07,0.360903E-01,0.390658E-02,
24152      &0.205923E-05,0.310726E-05,0.208123E-05,0.205923E-05,0.406686E-03,
24153      &0.329349E-08,0.314681E-01,0.335393E-02,0.174861E-05,0.278918E-05,
24154      &0.177007E-05,0.174861E-05,0.359402E-03,0.387747E-07,0.273932E-01,
24155      &0.287528E-02,0.149082E-05,0.250013E-05,0.151127E-05,0.149082E-05,
24156      &0.313779E-03,0.705560E-07,0.238068E-01,0.246132E-02,0.127582E-05,
24157      &0.223699E-05,0.129498E-05,0.127582E-05,0.272195E-03,0.975744E-07,
24158      &0.206558E-01,0.210383E-02,0.109488E-05,0.199657E-05,0.111257E-05,
24159      &0.109488E-05,0.234227E-03,0.118651E-06,0.178921E-01,0.179558E-02,
24160      &0.941584E-06,0.177694E-05,0.957733E-06,0.941584E-06,0.199907E-03,
24161      &0.133780E-06,0.154726E-01,0.153020E-02,0.811157E-06,0.157680E-05,
24162      &0.825743E-06,0.811157E-06,0.169849E-03,0.143581E-06,0.133582E-01,
24163      &0.130209E-02,0.699567E-06,0.139481E-05,0.712624E-06,0.699567E-06,
24164      &0.143794E-03,0.148591E-06,0.115137E-01,0.110634E-02,0.603631E-06,
24165      &0.122977E-05,0.615228E-06,0.603631E-06,0.121163E-03,0.149477E-06,
24166      &0.990774E-02,0.938615E-03,0.520920E-06,0.108072E-05,0.531148E-06/
24167       DATA (DL(K),K= 3486, 3570) /
24168      &0.520920E-06,0.101725E-03,0.147055E-06,0.851194E-02,0.795146E-03,
24169      &0.449441E-06,0.946634E-06,0.458405E-06,0.449441E-06,0.852238E-04,
24170      &0.142064E-06,0.730103E-02,0.672622E-03,0.387542E-06,0.826497E-06,
24171      &0.395353E-06,0.387542E-06,0.712290E-04,0.135149E-06,0.625244E-02,
24172      &0.568155E-03,0.333888E-06,0.719316E-06,0.340658E-06,0.333888E-06,
24173      &0.593824E-04,0.126902E-06,0.000000E+00,0.000000E+00,0.000000E+00,
24174      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24175      &0.457819E-01,0.409492E-02,0.105702E-05,0.105702E-05,0.105702E-05,
24176      &0.105702E-05,0.115350E-03,0.265810E-18,0.395724E-01,0.347873E-02,
24177      &0.812397E-06,0.103880E-05,0.815187E-06,0.812397E-06,0.160406E-03,
24178      &-.555147E-07,0.341639E-01,0.295295E-02,0.627904E-06,0.987449E-06,
24179      &0.632305E-06,0.627904E-06,0.174490E-03,-.847266E-07,0.294481E-01,
24180      &0.250329E-02,0.490075E-06,0.920197E-06,0.495305E-06,0.490075E-06,
24181      &0.174490E-03,-.944763E-07,0.253423E-01,0.211912E-02,0.387225E-06,
24182      &0.845257E-06,0.392760E-06,0.387225E-06,0.167111E-03,-.916775E-07,
24183      &0.217735E-01,0.179138E-02,0.309989E-06,0.766697E-06,0.315473E-06,
24184      &0.309989E-06,0.152540E-03,-.819158E-07,0.186760E-01,0.151211E-02/
24185       DATA (DL(K),K= 3571, 3655) /
24186      &0.252109E-06,0.688927E-06,0.257316E-06,0.252109E-06,0.135295E-03,
24187      &-.682145E-07,0.159921E-01,0.127447E-02,0.208612E-06,0.614302E-06,
24188      &0.213410E-06,0.208612E-06,0.118648E-03,-.528734E-07,0.136704E-01,
24189      &0.107254E-02,0.175203E-06,0.543807E-06,0.179526E-06,0.175203E-06,
24190      &0.102484E-03,-.379748E-07,0.116656E-01,0.901214E-03,0.149064E-06,
24191      &0.478363E-06,0.152890E-06,0.149064E-06,0.871530E-04,-.245007E-07,
24192      &0.993760E-02,0.756074E-03,0.128274E-06,0.418496E-06,0.131610E-06,
24193      &0.128274E-06,0.735682E-04,-.128491E-07,0.845081E-02,0.633315E-03,
24194      &0.111313E-06,0.364260E-06,0.114187E-06,0.111313E-06,0.617706E-04,
24195      &-.327698E-08,0.717398E-02,0.529654E-03,0.971373E-07,0.315568E-06,
24196      &0.995871E-07,0.971373E-07,0.514764E-04,0.421954E-08,0.607950E-02,
24197      &0.442265E-03,0.850687E-07,0.272228E-06,0.871375E-07,0.850687E-07,
24198      &0.426580E-04,0.982709E-08,0.514311E-02,0.368716E-03,0.746164E-07,
24199      &0.233927E-06,0.763489E-07,0.746164E-07,0.352463E-04,0.137715E-07,
24200      &0.434349E-02,0.306920E-03,0.654439E-07,0.200291E-06,0.668838E-07,
24201      &0.654439E-07,0.290260E-04,0.163078E-07,0.366196E-02,0.255085E-03,
24202      &0.573307E-07,0.170932E-06,0.585192E-07,0.573307E-07,0.238196E-04/
24203       DATA (DL(K),K= 3656, 3740) /
24204      &0.177037E-07,0.308217E-02,0.211681E-03,0.501185E-07,0.145441E-06,
24205      &0.510931E-07,0.501185E-07,0.195033E-04,0.182028E-07,0.258987E-02,
24206      &0.175396E-03,0.436915E-07,0.123415E-06,0.444860E-07,0.436915E-07,
24207      &0.159423E-04,0.180204E-07,0.000000E+00,0.000000E+00,0.000000E+00,
24208      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24209      &0.206951E-01,0.123383E-02,0.903693E-07,0.903693E-07,0.903693E-07,
24210      &0.903693E-07,0.147928E-04,0.131925E-18,0.174566E-01,0.102241E-02,
24211      &0.892028E-07,0.129792E-07,0.885875E-07,0.892028E-07,0.328931E-04,
24212      &0.168541E-07,0.147092E-01,0.846741E-03,0.841992E-07,-.346085E-07,
24213      &0.832249E-07,0.841992E-07,0.410825E-04,0.262547E-07,0.123736E-01,
24214      &0.700287E-03,0.769173E-07,-.620958E-07,0.757563E-07,0.769173E-07,
24215      &0.418512E-04,0.305542E-07,0.103910E-01,0.578275E-03,0.688622E-07,
24216      &-.753692E-07,0.676306E-07,0.688622E-07,0.392599E-04,0.318183E-07,
24217      &0.871109E-02,0.476815E-03,0.611778E-07,-.782788E-07,0.599557E-07,
24218      &0.611778E-07,0.356221E-04,0.316149E-07,0.728984E-02,0.392546E-03,
24219      &0.537256E-07,-.749101E-07,0.525642E-07,0.537256E-07,0.312295E-04,
24220      &0.301630E-07,0.608951E-02,0.322656E-03,0.466227E-07,-.678673E-07/
24221       DATA (DL(K),K= 3741, 3825) /
24222      &0.455521E-07,0.466227E-07,0.265816E-04,0.278681E-07,0.507758E-02,
24223      &0.264779E-03,0.400790E-07,-.588670E-07,0.391148E-07,0.400790E-07,
24224      &0.223044E-04,0.251720E-07,0.422604E-02,0.216927E-03,0.341205E-07,
24225      &-.492124E-07,0.332680E-07,0.341205E-07,0.185283E-04,0.222885E-07,
24226      &0.351082E-02,0.177427E-03,0.287480E-07,-.397442E-07,0.280058E-07,
24227      &0.287480E-07,0.152122E-04,0.193702E-07,0.291126E-02,0.144878E-03,
24228      &0.239699E-07,-.309608E-07,0.233320E-07,0.239699E-07,0.123840E-04,
24229      &0.165481E-07,0.240962E-02,0.118102E-03,0.197695E-07,-.231453E-07,
24230      &0.192276E-07,0.197695E-07,0.100316E-04,0.139043E-07,0.199075E-02,
24231      &0.961132E-04,0.161186E-07,-.164194E-07,0.156628E-07,0.161186E-07,
24232      &0.808648E-05,0.114903E-07,0.164168E-02,0.780880E-04,0.129826E-07,
24233      &-.107955E-07,0.126029E-07,0.129826E-07,0.648861E-05,0.933575E-08,
24234      &0.135135E-02,0.633381E-04,0.103192E-07,-.622051E-08,0.100055E-07,
24235      &0.103192E-07,0.519042E-05,0.744979E-08,0.111036E-02,0.512898E-04,
24236      &0.808255E-08,-.260101E-08,0.782557E-08,0.808255E-08,0.414192E-05,
24237      &0.582811E-08,0.910718E-03,0.414657E-04,0.622640E-08,0.177583E-09,
24238      &0.601750E-08,0.622640E-08,0.329729E-05,0.445766E-08,0.745657E-03/
24239       DATA (DL(K),K= 3826, 3910) /
24240      &0.334694E-04,0.470431E-08,0.223586E-08,0.453577E-08,0.470431E-08,
24241      &0.261981E-05,0.331859E-08,0.000000E+00,0.000000E+00,0.000000E+00,
24242      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,
24243      &0.519165E-02,0.154752E-03,0.135983E-08,0.135983E-08,0.135983E-08,
24244      &0.135983E-08,0.445189E-06,0.165858E-19,0.420352E-02,0.123002E-03,
24245      &-.202651E-07,0.730203E-07,-.200511E-07,-.202651E-07,0.358557E-05,
24246      &-.213089E-07,0.340143E-02,0.977718E-04,-.356451E-07,0.114908E-06,
24247      &-.353066E-07,-.356451E-07,0.384652E-05,-.364475E-07,0.274771E-02,
24248      &0.776124E-04,-.435588E-07,0.139200E-06,-.431556E-07,-.435588E-07,
24249      &0.404834E-05,-.441752E-07,0.221524E-02,0.614950E-04,-.471629E-07,
24250      &0.150069E-06,-.467352E-07,-.471629E-07,0.391615E-05,-.476355E-07,
24251      &0.178268E-02,0.486476E-04,-.477545E-07,0.151420E-06,-.473296E-07,
24252      &-.477545E-07,0.334100E-05,-.481163E-07,0.143185E-02,0.384202E-04,
24253      &-.462359E-07,0.146515E-06,-.458316E-07,-.462359E-07,0.275426E-05,
24254      &-.465126E-07,0.114781E-02,0.302894E-04,-.434031E-07,0.137587E-06,
24255      &-.430295E-07,-.434031E-07,0.226010E-05,-.436143E-07,0.918288E-03,
24256      &0.238367E-04,-.398089E-07,0.126321E-06,-.394715E-07,-.398089E-07/
24257       DATA (DL(K),K= 3911, 3995) /
24258      &0.180947E-05,-.399700E-07,0.733193E-03,0.187249E-04,-.358525E-07,
24259      &0.113940E-06,-.355529E-07,-.358525E-07,0.142045E-05,-.359751E-07,
24260      &0.584227E-03,0.146823E-04,-.318183E-07,0.101291E-06,-.315563E-07,
24261      &-.318183E-07,0.110919E-05,-.319115E-07,0.464586E-03,0.114914E-04,
24262      &-.278936E-07,0.889550E-07,-.276671E-07,-.278936E-07,0.860964E-06,
24263      &-.279643E-07,0.368700E-03,0.897731E-05,-.241972E-07,0.773096E-07,
24264      &-.240033E-07,-.241972E-07,0.662825E-06,-.242508E-07,0.292013E-03,
24265      &0.700034E-05,-.208001E-07,0.665779E-07,-.206356E-07,-.208001E-07,
24266      &0.508061E-06,-.208406E-07,0.230814E-03,0.544870E-05,-.177366E-07,
24267      &0.568734E-07,-.175982E-07,-.177366E-07,0.388493E-06,-.177672E-07,
24268      &0.182078E-03,0.423324E-05,-.150157E-07,0.482316E-07,-.149000E-07,
24269      &-.150157E-07,0.296111E-06,-.150387E-07,0.143349E-03,0.328297E-05,
24270      &-.126295E-07,0.406343E-07,-.125335E-07,-.126295E-07,0.225104E-06,
24271      &-.126468E-07,0.112639E-03,0.254145E-05,-.105595E-07,0.340280E-07,
24272      &-.104803E-07,-.105595E-07,0.170871E-06,-.105726E-07,0.883377E-04,
24273      &0.196395E-05,-.878062E-08,0.283380E-07,-.871555E-08,-.878062E-08,
24274      &0.129517E-06,-.879039E-08,0.000000E+00,0.000000E+00,0.000000E+00/
24275       DATA (DL(K),K= 3996, 4000) /
24276      &0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00,0.000000E+00/
24277 C
24278       ANS = 0.
24279       IF (X.GT.0.9985) RETURN
24280       IF ( ((I.EQ.3).OR.(I.EQ.8)) .AND. (X.GT.0.95) ) RETURN
24281 C
24282       IS  = S/DELTA+1
24283       IS1 = IS+1
24284       DO 1 L=1,25
24285          KL    = L+NDRV*25
24286          F1(L) = GF(I,IS,KL)
24287          F2(L) = GF(I,IS1,KL)
24288     1 CONTINUE
24289       A1 = DT_CKMTFF(X,F1)
24290       A2 = DT_CKMTFF(X,F2)
24291 C      A1=ALOG(A1)
24292 C      A2=ALOG(A2)
24293       S1  = (IS-1)*DELTA
24294       S2  = S1+DELTA
24295       ANS = A1*(S-S2)/(S1-S2)+A2*(S-S1)/(S2-S1)
24296 C      ANS=EXP(ANS)
24297       RETURN
24298       END
24299 C
24300
24301 *$ CREATE DT_CKMTFF.FOR
24302 *COPY DT_CKMTFF
24303       FUNCTION DT_CKMTFF(X,FVL)
24304 C**********************************************************************
24305 C
24306 C     LOGARITHMIC INTERPOLATOR - WATCH OUT FOR NEGATIVE
24307 C     FUNCTIONS AND/OR X VALUES OUTSIDE THE RANGE 0 TO 1.
24308 C     NOTE: DIMENSION OF FVL IS OVERWRITTEN BY VALUE USED
24309 C     IN MAIN ROUTINE.
24310 C
24311 C**********************************************************************
24312
24313       SAVE
24314       DIMENSION FVL(25),XGRID(25)
24315       DATA NX,XGRID/25,.001,.002,.004,.008,.016,.032,.064,.1,.15,
24316      *.2,.25,.3,.35,.4,.45,.5,.55,.6,.65,.7,.75,.8,.85,.9,.95/
24317 C
24318       DT_CKMTFF=0.
24319       DO 1 I=1,NX
24320       IF(X.LT.XGRID(I)) GO TO 2
24321     1 CONTINUE
24322     2 I=I-1
24323       IF(I.EQ.0) THEN
24324          I=I+1
24325       ELSE IF(I.GT.23) THEN
24326          I=23
24327       ENDIF
24328       J=I+1
24329       K=J+1
24330       AXI=LOG(XGRID(I))
24331       BXI=LOG(1.-XGRID(I))
24332       AXJ=LOG(XGRID(J))
24333       BXJ=LOG(1.-XGRID(J))
24334       AXK=LOG(XGRID(K))
24335       BXK=LOG(1.-XGRID(K))
24336       FI=LOG(ABS(FVL(I)) +1.E-15)
24337       FJ=LOG(ABS(FVL(J)) +1.E-16)
24338       FK=LOG(ABS(FVL(K)) +1.E-17)
24339       DET=AXI*(BXJ-BXK)+AXJ*(BXK-BXI)+AXK*(BXI-BXJ)
24340       ALOGA=(FI*(AXJ*BXK-AXK*BXJ)+FJ*(AXK*BXI-AXI*BXK)+FK*(AXI*BXJ-AXJ*
24341      $ BXI))/DET
24342       ALPHA=(FI*(BXJ-BXK)+FJ*(BXK-BXI)+FK*(BXI-BXJ))/DET
24343       BETA=(FI*(AXK-AXJ)+FJ*(AXI-AXK)+FK*(AXJ-AXI))/DET
24344       IF(ABS(ALPHA).GT.99..OR.ABS(BETA).GT.99..OR.ABS(ALOGA).GT.99.)
24345      1RETURN
24346 C      IF(ALPHA.GT.50..OR.BETA.GT.50.) THEN
24347 C         WRITE(6,2001) X,FVL
24348 C 2001    FORMAT(8E12.4)
24349 C         WRITE(6,2001) ALPHA,BETA,ALOGA,DET
24350 C      ENDIF
24351       DT_CKMTFF=EXP(ALOGA)*X**ALPHA*(1.-X)**BETA
24352       RETURN
24353       END
24354
24355 *$ CREATE DT_FLUINI.FOR
24356 *COPY DT_FLUINI
24357 *
24358 *===fluini=============================================================*
24359 *
24360       SUBROUTINE DT_FLUINI
24361
24362 ************************************************************************
24363 * Initialisation of the nucleon-nucleon cross section fluctuation      *
24364 * treatment. The original version by J. Ranft.                         *
24365 * This version dated 21.04.95 is revised by S. Roesler.                *
24366 ************************************************************************
24367
24368       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24369       SAVE
24370
24371       PARAMETER ( LINP = 10 ,
24372      &            LOUT = 6 ,
24373      &            LDAT = 9 )
24374
24375       PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
24376
24377       PARAMETER ( A     = 0.1D0,
24378      &            B     = 0.893D0,
24379      &            OM    = 1.1D0,
24380      &            N     = 6,
24381      &            DX    = 0.003D0)
24382
24383 * n-n cross section fluctuations
24384       PARAMETER (NBINS = 1000)
24385       COMMON /DTXSFL/ FLUIXX(NBINS),IFLUCT
24386       DIMENSION FLUSI(NBINS),FLUIX(NBINS)
24387
24388       WRITE(LOUT,1000)
24389  1000 FORMAT(/,1X,'FLUINI:  hadronic cross section fluctuations ',
24390      &       'treated')
24391
24392       FLUSU  = ZERO
24393       FLUSUU = ZERO
24394
24395       DO 1 I=1,NBINS
24396          X        = DBLE(I)*DX
24397          FLUIX(I) = X
24398          FLUS     = ((X-B)/(OM*B))**N
24399          IF (FLUS.LE.20.0D0) THEN
24400             FLUSI(I) = (X/B)*EXP(-FLUS)/(X/B+A)
24401          ELSE
24402             FLUSI(I) = ZERO
24403          ENDIF
24404          FLUSU = FLUSU+FLUSI(I)
24405     1 CONTINUE
24406       DO 2 I=1,NBINS
24407          FLUSUU   = FLUSUU+FLUSI(I)/FLUSU
24408          FLUSI(I) = FLUSUU
24409     2 CONTINUE
24410
24411 C     WRITE(LOUT,1001)
24412 C1001 FORMAT(1X,'FLUCTUATIONS')
24413 C     CALL PLOT(FLUIX,FLUSI,1000,1,1000,0.0D0,0.06D0,0.0D0,0.01D0)
24414
24415       DO 3 I=1,NBINS
24416          AF = DBLE(I)*0.001D0
24417          DO 4 J=1,NBINS
24418             IF (AF.LE.FLUSI(J)) THEN
24419                FLUIXX(I) = FLUIX(J)
24420                GOTO 5
24421             ENDIF
24422     4    CONTINUE
24423     5    CONTINUE
24424     3 CONTINUE
24425       FLUIXX(1)     = FLUIX(1)
24426       FLUIXX(NBINS) = FLUIX(NBINS)
24427
24428       RETURN
24429       END
24430
24431 *$ CREATE DT_SIGTBL.FOR
24432 *COPY DT_SIGTBL
24433 *
24434 *===sigtab=============================================================*
24435 *
24436       SUBROUTINE DT_SIGTBL(JP,JT,PTOT,SIGE,MODE)
24437
24438 ************************************************************************
24439 * This version dated 18.11.95 is written by S. Roesler                 *
24440 ************************************************************************
24441
24442       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24443       SAVE
24444
24445       PARAMETER ( LINP = 10 ,
24446      &            LOUT = 6 ,
24447      &            LDAT = 9 )
24448
24449       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24450      &           OHALF=0.5D0,ONE=1.0D0)
24451       PARAMETER (PLO=0.01D0,PHI=20.0D0,NBINS=150)
24452
24453       LOGICAL LINIT
24454
24455 * particle properties (BAMJET index convention)
24456       CHARACTER*8  ANAME
24457       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24458      &                IICH(210),IIBAR(210),K1(210),K2(210)
24459
24460       DIMENSION SIGEP(5,NBINS+1),SIGEN(5,NBINS+1),IDSIG(23)
24461       DATA IDSIG / 1, 0, 0, 0, 0, 0, 0, 2, 0, 0,
24462      &             0, 0, 3, 4, 0, 0, 0, 0, 0, 0,
24463      &             0, 0, 5/
24464       DATA LINIT /.FALSE./
24465
24466 * precalculation and tabulation of elastic cross sections
24467       IF (ABS(MODE).EQ.1) THEN
24468          IF (MODE.EQ.1)
24469      &      OPEN(LDAT,FILE='outdata0/sigtab.out',STATUS='UNKNOWN')
24470          PLABLX = LOG10(PLO)
24471          PLABHX = LOG10(PHI)
24472          DPLAB  = (PLABHX-PLABLX)/DBLE(NBINS)
24473          DO 1 I=1,NBINS+1
24474             PLAB = PLABLX+DBLE(I-1)*DPLAB
24475             PLAB = 10**PLAB
24476             DO 2 IPROJ=1,23
24477                IDX = IDSIG(IPROJ)
24478                IF (IDX.GT.0) THEN
24479 C                 CALL DT_SIHNEL(IPROJ,1,PLAB,SIGEP(IDX,I))
24480 C                 CALL DT_SIHNEL(IPROJ,8,PLAB,SIGEN(IDX,I))
24481                   DUMZER = ZERO
24482                   CALL DT_XSHN(IPROJ,1,PLAB,DUMZER,SIGTOT,SIGEP(IDX,I))
24483                   CALL DT_XSHN(IPROJ,8,PLAB,DUMZER,SIGTOT,SIGEN(IDX,I))
24484                ENDIF
24485     2       CONTINUE
24486             IF (MODE.EQ.1) THEN
24487                WRITE(LDAT,1000) PLAB,(SIGEP(IDX,I),IDX=1,5),
24488      &                                (SIGEN(IDX,I),IDX=1,5)
24489  1000          FORMAT(F5.1,10F7.2)
24490             ENDIF
24491     1    CONTINUE
24492          IF (MODE.EQ.1) CLOSE(LDAT)
24493          LINIT = .TRUE.
24494       ELSE
24495          SIGE = -ONE
24496          IF (LINIT.AND.(JP.LE.23).AND.(PTOT.GE.PLO)
24497      &                           .AND.(PTOT.LE.PHI) ) THEN
24498             IDX = IDSIG(JP)
24499             IF ( (IDX.GT.0).AND.((JT.EQ.1).OR.(JT.EQ.8)) ) THEN
24500                PLABX = LOG10(PTOT)
24501                IF (PLABX.LE.PLABLX) THEN
24502                   I1 = 1
24503                   I2 = 1
24504                ELSEIF (PLABX.GE.PLABHX) THEN
24505                   I1 = NBINS+1
24506                   I2 = NBINS+1
24507                ELSE
24508                   I1 = INT((PLABX-PLABLX)/DPLAB)+1
24509                   I2 = I1+1
24510                ENDIF
24511                PLAB1X = PLABLX+DBLE(I1-1)*DPLAB
24512                PLAB2X = PLABLX+DBLE(I2-1)*DPLAB
24513                PBIN   = PLAB2X-PLAB1X
24514                IF (PBIN.GT.TINY10) THEN
24515                   RATX = (PLABX-PLAB1X)/(PLAB2X-PLAB1X)
24516                ELSE
24517                   RATX = ZERO
24518                ENDIF
24519                IF (JT.EQ.1) THEN
24520                   SIG1 = SIGEP(IDX,I1)
24521                   SIG2 = SIGEP(IDX,I2)
24522                ELSE
24523                   SIG1 = SIGEN(IDX,I1)
24524                   SIG2 = SIGEN(IDX,I2)
24525                ENDIF
24526                SIGE = SIG1+RATX*(SIG2-SIG1)
24527             ENDIF
24528          ENDIF
24529       ENDIF
24530
24531       RETURN
24532       END
24533
24534 *$ CREATE DT_XSTABL.FOR
24535 *COPY DT_XSTABL
24536 *
24537 *===xstabl=============================================================*
24538 *
24539       SUBROUTINE DT_XSTABL(WHAT,IXSQEL,IRATIO)
24540
24541       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24542       SAVE
24543
24544       PARAMETER ( LINP = 10 ,
24545      &            LOUT = 6 ,
24546      &            LDAT = 9 )
24547
24548       PARAMETER (TINY10=1.0D-10,TINY2=1.0D-2,ZERO=0.0D0,DLARGE=1.0D10,
24549      &           OHALF=0.5D0,ONE=1.0D0,TWO=2.0D0)
24550       LOGICAL LLAB,LELOG,LQLOG
24551
24552 * particle properties (BAMJET index convention)
24553       CHARACTER*8  ANAME
24554       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
24555      &                IICH(210),IIBAR(210),K1(210),K2(210)
24556
24557 * properties of interacting particles
24558       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
24559
24560       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
24561
24562 * Glauber formalism: cross sections
24563       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
24564      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
24565      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
24566      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
24567      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
24568      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
24569      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
24570      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
24571      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
24572      &                BSLOPE,NEBINI,NQBINI
24573
24574 * emulsion treatment
24575       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
24576      &                NCOMPO,IEMUL
24577
24578       DIMENSION WHAT(6)
24579
24580       LLAB   = (WHAT(1).GT.ZERO).OR.(WHAT(2).GT.ZERO)
24581       ELO    = ABS(WHAT(1))
24582       EHI    = ABS(WHAT(2))
24583       IF (ELO.GT.EHI) ELO = EHI
24584       LELOG  = WHAT(3).LT.ZERO
24585       NEBINS = MAX(INT(ABS(WHAT(3))),1)
24586       DEBINS = (EHI-ELO)/DBLE(NEBINS)
24587       IF (LELOG) THEN
24588          AELO   = LOG10(ELO)
24589          AEHI   = LOG10(EHI)
24590          ADEBIN = (AEHI-AELO)/DBLE(NEBINS)
24591       ENDIF
24592       Q2LO   = WHAT(4)
24593       Q2HI   = WHAT(5)
24594       IF (Q2LO.GT.Q2HI) Q2LO = Q2HI
24595       LQLOG  = WHAT(6).LT.ZERO
24596       NQBINS = MAX(INT(ABS(WHAT(6))),1)
24597       DQBINS = (Q2HI-Q2LO)/DBLE(NQBINS)
24598       IF (LQLOG) THEN
24599          AQ2LO  = LOG10(Q2LO)
24600          AQ2HI  = LOG10(Q2HI)
24601          ADQBIN = (AQ2HI-AQ2LO)/DBLE(NQBINS)
24602       ENDIF
24603
24604       IF ( ELO.EQ. EHI) NEBINS = 0
24605       IF (Q2LO.EQ.Q2HI) NQBINS = 0
24606
24607       WRITE(LOUT,1000) ELO,EHI,LLAB,IXSQEL,Q2LO,Q2HI,IJPROJ,IP,IT
24608  1000 FORMAT(/,1X,'XSTABL:  E_lo  =',E10.3,' GeV  E_hi  =',E10.3,
24609      &       ' GeV     Lab = ',L1,'  qel: ',I2,/,10X,'Q2_lo =',F10.5,
24610      &       ' GeV^2  Q2_hi =',F10.5,' GeV^2',/,10X,'id_p = ',I2,
24611      &       '   A_p = ',I3,'   A_t = ',I3,/)
24612
24613 C     IF (IJPROJ.NE.7) THEN
24614          WRITE(LOUT,'(1X,A,/)')'(E,STOT,SELA,SQEP,SQET,SQE2,SINE,SPROD)'
24615 * normalize fractions of emulsion components
24616          IF (NCOMPO.GT.0) THEN
24617             SUMFRA = ZERO
24618             DO 10 I=1,NCOMPO
24619                SUMFRA = SUMFRA+EMUFRA(I)
24620    10       CONTINUE
24621             IF (SUMFRA.GT.ZERO) THEN
24622                DO 11 I=1,NCOMPO
24623                   EMUFRA(I) = EMUFRA(I)/SUMFRA
24624    11          CONTINUE
24625             ENDIF
24626          ENDIF
24627 C     ELSE
24628 C        WRITE(LOUT,'(1X,A,/)') '(Q2,E,STOT,ETOT,SIN,EIN,STOT0)'
24629 C     ENDIF
24630       DO 1 I=1,NEBINS+1
24631          IF (LELOG) THEN
24632             E = 10**(AELO+DBLE(I-1)*ADEBIN)
24633          ELSE
24634             E = ELO+DBLE(I-1)*DEBINS
24635          ENDIF
24636          DO 2 J=1,NQBINS+1
24637             IF (LQLOG) THEN
24638                Q2 = 10**(AQ2LO+DBLE(J-1)*ADQBIN)
24639             ELSE
24640                Q2 = Q2LO+DBLE(J-1)*DQBINS
24641             ENDIF
24642 c            IF (IJPROJ.NE.7) THEN
24643                IF (LLAB) THEN
24644                   PLAB = ZERO
24645                   ECM  = ZERO
24646                   CALL DT_LTINI(IJPROJ,1,E,PPN0,ECM,0)
24647                ELSE
24648                   ECM = E
24649                ENDIF
24650                XI  = ZERO
24651                Q2I = ZERO
24652                IF (IJPROJ.EQ.7) Q2I = Q2
24653                IF (NCOMPO.GT.0) THEN
24654                   DO 20 IC=1,NCOMPO
24655                      IIT = IEMUMA(IC)
24656                      CALL DT_XSGLAU(IP,IIT,IJPROJ,XI,Q2I,ECM,1,1,-IC)
24657    20             CONTINUE
24658                ELSE
24659                   CALL DT_XSGLAU(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,-1)
24660 C                 CALL AMPLIT(IP,IT,IJPROJ,XI,Q2I,ECM,1,1,1)
24661                ENDIF
24662                IF (NCOMPO.GT.0) THEN
24663                   XTOT = ZERO
24664                   ETOT = ZERO
24665                   XELA = ZERO
24666                   EELA = ZERO
24667                   XQEP = ZERO
24668                   EQEP = ZERO
24669                   XQET = ZERO
24670                   EQET = ZERO
24671                   XQE2 = ZERO
24672                   EQE2 = ZERO
24673                   XPRO = ZERO
24674                   EPRO = ZERO
24675                   XPRO1= ZERO
24676                   XDEL = ZERO
24677                   EDEL = ZERO
24678                   XDQE = ZERO
24679                   EDQE = ZERO
24680                   DO 21 IC=1,NCOMPO
24681                      XTOT = XTOT+EMUFRA(IC)*XSTOT(1,1,IC)
24682                      ETOT = ETOT+EMUFRA(IC)*XETOT(1,1,IC)**2
24683                      XELA = XELA+EMUFRA(IC)*XSELA(1,1,IC)
24684                      EELA = EELA+EMUFRA(IC)*XEELA(1,1,IC)**2
24685                      XQEP = XQEP+EMUFRA(IC)*XSQEP(1,1,IC)
24686                      EQEP = EQEP+EMUFRA(IC)*XEQEP(1,1,IC)**2
24687                      XQET = XQET+EMUFRA(IC)*XSQET(1,1,IC)
24688                      EQET = EQET+EMUFRA(IC)*XEQET(1,1,IC)**2
24689                      XQE2 = XQE2+EMUFRA(IC)*XSQE2(1,1,IC)
24690                      EQE2 = EQE2+EMUFRA(IC)*XEQE2(1,1,IC)**2
24691                      XPRO = XPRO+EMUFRA(IC)*XSPRO(1,1,IC)
24692                      EPRO = EPRO+EMUFRA(IC)*XEPRO(1,1,IC)**2
24693                      XDEL = XDEL+EMUFRA(IC)*XSDEL(1,1,IC)
24694                      EDEL = EDEL+EMUFRA(IC)*XEDEL(1,1,IC)**2
24695                      XDQE = XDQE+EMUFRA(IC)*XSDQE(1,1,IC)
24696                      EDQE = EDQE+EMUFRA(IC)*XEDQE(1,1,IC)**2
24697                      YPRO = XSTOT(1,1,IC)-XSELA(1,1,IC)
24698      &                     -XSQEP(1,1,IC)-XSQET(1,1,IC)
24699      &                     -XSQE2(1,1,IC)
24700                      XPRO1= XPRO1+EMUFRA(IC)*YPRO
24701    21             CONTINUE
24702                   ETOT = SQRT(ETOT)
24703                   EELA = SQRT(EELA)
24704                   EQEP = SQRT(EQEP)
24705                   EQET = SQRT(EQET)
24706                   EQE2 = SQRT(EQE2)
24707                   EPRO = SQRT(EPRO)
24708                   EDEL = SQRT(EDEL)
24709                   EDQE = SQRT(EDQE)
24710                   WRITE(LOUT,'(8E9.3)')
24711      &               E,XTOT,XELA,XQEP,XQET,XQE2,XPRO,XPRO1
24712 C                 WRITE(LOUT,'(4E9.3)')
24713 C    &               E,XDEL,XDQE,XDEL+XDQE
24714                ELSE
24715                   WRITE(LOUT,'(11E10.3)')
24716      &              E,
24717      &              XSTOT(1,1,1),XSELA(1,1,1),XSQEP(1,1,1),XSQET(1,1,1),
24718      &              XSQE2(1,1,1),XSPRO(1,1,1),
24719      &              XSTOT(1,1,1)-XSELA(1,1,1)-XSQEP(1,1,1)-XSQET(1,1,1)
24720      &             -XSQE2(1,1,1),XSDEL(1,1,1),XSDQE(1,1,1),
24721      &              XSDEL(1,1,1)+XSDQE(1,1,1)
24722 C                 WRITE(LOUT,'(4E9.3)') E,XSDEL(1,1,1),XSDQE(1,1,1),
24723 C    &                                    XSDEL(1,1,1)+XSDQE(1,1,1)
24724                ENDIF
24725 c            ELSE
24726 c               IF (LLAB) THEN
24727 c                  IF (IT.GT.1) THEN
24728 c                     IF (IXSQEL.EQ.0) THEN
24729 cC                       CALL DT_SIGGA(IT,  Q2, E,ZERO,ZERO,
24730 cC                       CALL DT_SIGGA(IT,   E,Q2,ZERO,ZERO,
24731 c                        CALL DT_SIGGA(IT,ZERO,Q2,ZERO,E,
24732 c     &                             STOT,ETOT,SIN,EIN,STOT0)
24733 c                        IF (IRATIO.EQ.1) THEN
24734 c                           CALL DT_SIGGP(  Q2, E,ZERO,ZERO,STGP,SIGP,SDGP)
24735 cC                          CALL DT_SIGGP(   E,Q2,ZERO,ZERO,STGP,SIGP,SDGP)
24736 cC                          CALL DT_SIGGP(ZERO,Q2,ZERO,E,STGP,SIGP,SDGP)
24737 c*!! save cross sections
24738 c                           STOTA = STOT
24739 c                           ETOTA = ETOT
24740 c                           STOTP = STGP
24741 c*!!
24742 c                           STOT  = STOT/(DBLE(IT)*STGP)
24743 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
24744 c                           STOT0 = STGP
24745 c                           ETOT  = ZERO
24746 c                           EIN   = ZERO
24747 c                        ENDIF
24748 c                     ELSE
24749 c                        WRITE(LOUT,*)
24750 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
24751 c                        STOP
24752 c                     ENDIF
24753 c                  ELSE
24754 c                     ETOT = ZERO
24755 c                     EIN  = ZERO
24756 c                     STOT0= ZERO
24757 c                     IF (IXSQEL.EQ.0) THEN
24758 c                        CALL DT_SIGGP(ZERO,Q2,ZERO,E,STOT,SIN,SDIR)
24759 c                     ELSE
24760 c                       SIN = ZERO
24761 c                       CALL DT_SIGVEL(ZERO,Q2,ZERO,E,IXSQEL,STOT,SIN,STOT0)
24762 c                     ENDIF
24763 c                  ENDIF
24764 c               ELSE
24765 c                  IF (IT.GT.1) THEN
24766 c                     IF (IXSQEL.EQ.0) THEN
24767 c                        CALL DT_SIGGA(IT,ZERO,Q2,E,ZERO,
24768 c     &                             STOT,ETOT,SIN,EIN,STOT0)
24769 c                        IF (IRATIO.EQ.1) THEN
24770 c                           CALL DT_SIGGP(ZERO,Q2,E,ZERO,STGP,SIGP,SDGP)
24771 c*!! save cross sections
24772 c                           STOTA = STOT
24773 c                           ETOTA = ETOT
24774 c                           STOTP = STGP
24775 c*!!
24776 c                           STOT  = STOT/(DBLE(IT)*STGP)
24777 c                           SIN   =  SIN/(DBLE(IT)*SIGP)
24778 c                           STOT0 = STGP
24779 c                           ETOT  = ZERO
24780 c                           EIN   = ZERO
24781 c                        ENDIF
24782 c                     ELSE
24783 c                        WRITE(LOUT,*)
24784 c     &                  ' XSTABL:  qel. xs. not implemented for nuclei'
24785 c                        STOP
24786 c                     ENDIF
24787 c                  ELSE
24788 c                     ETOT = ZERO
24789 c                     EIN  = ZERO
24790 c                     STOT0= ZERO
24791 c                     IF (IXSQEL.EQ.0) THEN
24792 c                        CALL DT_SIGGP(ZERO,Q2,E,ZERO,STOT,SIN,SDIR)
24793 c                     ELSE
24794 c                       SIN = ZERO
24795 c                       CALL DT_SIGVEL(ZERO,Q2,E,ZERO,IXSQEL,STOT,SIN,STOT0)
24796 c                     ENDIF
24797 c                  ENDIF
24798 c               ENDIF
24799 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,STOTA,ETOTA,STOTP,ZERO
24800 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,SDIR
24801 cC              WRITE(LOUT,'(1X,7E10.3)')Q2,E,STOT,ETOT,SIN,EIN,STOT0
24802 c               WRITE(LOUT,'(1X,6E10.3)')Q2,E,STOT,ETOT,SIN,EIN
24803 c            ENDIF
24804     2    CONTINUE
24805     1 CONTINUE
24806
24807       RETURN
24808       END
24809
24810 *$ CREATE DT_TESTXS.FOR
24811 *COPY DT_TESTXS
24812 *
24813 *===testxs=============================================================*
24814 *
24815       SUBROUTINE DT_TESTXS
24816
24817       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24818       SAVE
24819
24820       DIMENSION XSTOT(26,2),XSELA(26,2)
24821
24822       OPEN(10,FILE='testxs_ptot.out',STATUS='UNKNOWN')
24823       OPEN(11,FILE='testxs_pela.out',STATUS='UNKNOWN')
24824       OPEN(12,FILE='testxs_ntot.out',STATUS='UNKNOWN')
24825       OPEN(13,FILE='testxs_nela.out',STATUS='UNKNOWN')
24826       DUMECM = 0.0D0
24827       PLABL = 0.01D0
24828       PLABH = 10000.0D0
24829       NBINS = 120
24830       APLABL = LOG10(PLABL)
24831       APLABH = LOG10(PLABH)
24832       ADPLAB = (APLABH-APLABL)/DBLE(NBINS)
24833       DO 1 I=1,NBINS+1
24834          ADP = APLABL+DBLE(I-1)*ADPLAB
24835          P = 10.0D0**ADP
24836          DO 2 J=1,26
24837             CALL DT_XSHN(J,1,P,DUMECM,XSTOT(J,1),XSELA(J,1))
24838             CALL DT_XSHN(J,8,P,DUMECM,XSTOT(J,2),XSELA(J,2))
24839     2    CONTINUE
24840          WRITE(10,1000) P,(XSTOT(K,1),K=1,26)
24841          WRITE(11,1000) P,(XSELA(K,1),K=1,26)
24842          WRITE(12,1000) P,(XSTOT(K,2),K=1,26)
24843          WRITE(13,1000) P,(XSELA(K,2),K=1,26)
24844     1 CONTINUE
24845  1000 FORMAT(F8.3,26F9.3)
24846
24847       RETURN
24848       END
24849 ************************************************************************
24850 *                                                                      *
24851 *  DTUNUC 2.0:   library routines                                      *
24852 *                                   processed by S. Roesler, 6.5.95    *
24853 *                                                                      *
24854 ************************************************************************
24855 *
24856 *     1) Handling of parton momenta
24857 *          SUBROUTINE MASHEL
24858 *          SUBROUTINE DFERMI
24859 *
24860 *     2) Handling of parton flavors and particle indices
24861 *          INTEGER FUNCTION IPDG2B
24862 *          INTEGER FUNCTION IB2PDG
24863 *          INTEGER FUNCTION IQUARK
24864 *          INTEGER FUNCTION IBJQUA
24865 *          INTEGER FUNCTION ICIHAD
24866 *          INTEGER FUNCTION IPDGHA
24867 *          INTEGER FUNCTION MCHAD
24868 *          SUBROUTINE FLAHAD
24869 *
24870 *     3) Energy-momentum and quantum number conservation check routines
24871 *          SUBROUTINE EMC1
24872 *          SUBROUTINE EMC2
24873 *          SUBROUTINE EVTEMC
24874 *          SUBROUTINE EVTFLC
24875 *          SUBROUTINE EVTCHG
24876 *
24877 *     4) Transformations
24878 *          SUBROUTINE LTINI
24879 *          SUBROUTINE LTRANS
24880 *          SUBROUTINE LTNUC
24881 *          SUBROUTINE DALTRA
24882 *          SUBROUTINE DTRAFO
24883 *          SUBROUTINE STTRAN
24884 *          SUBROUTINE MYTRAN
24885 *          SUBROUTINE LT2LAO
24886 *          SUBROUTINE LT2LAB
24887 *
24888 *     5) Sampling from distributions
24889 *          INTEGER FUNCTION NPOISS
24890 *          DOUBLE PRECISION FUNCTION SAMPXB
24891 *          DOUBLE PRECISION FUNCTION SAMPEX
24892 *          DOUBLE PRECISION FUNCTION SAMSQX
24893 *          DOUBLE PRECISION FUNCTION BETREJ
24894 *          DOUBLE PRECISION FUNCTION DGAMRN
24895 *          DOUBLE PRECISION FUNCTION DBETAR
24896 *          SUBROUTINE RANNOR
24897 *          SUBROUTINE DPOLI
24898 *          SUBROUTINE DSFECF
24899 *          SUBROUTINE RACO
24900 *
24901 *     6) Special functions, algorithms and service routines
24902 *          DOUBLE PRECISION FUNCTION YLAMB
24903 *          SUBROUTINE SORT
24904 *          SUBROUTINE SORT1
24905 *          SUBROUTINE DT_XTIME
24906 *
24907 *     7) Random number generator package
24908 *          DOUBLE PRECISION FUNCTION DT_RNDM
24909 *          SUBROUTINE DT_RNDMST
24910 *          SUBROUTINE DT_RNDMIN
24911 *          SUBROUTINE DT_RNDMOU
24912 *          SUBROUTINE DT_RNDMTE
24913 *
24914 ************************************************************************
24915 *                                                                      *
24916 *                 1) Handling of parton momenta                        *
24917 *                                                                      *
24918 ************************************************************************
24919 *$ CREATE DT_MASHEL.FOR
24920 *COPY DT_MASHEL
24921 *
24922 *===mashel=============================================================*
24923 *
24924       SUBROUTINE DT_MASHEL(PA1,PA2,XM1,XM2,P1,P2,IREJ)
24925
24926 ************************************************************************
24927 *                                                                      *
24928 *    rescaling of momenta of two partons to put both                   *
24929 *                                       on mass shell                  *
24930 *                                                                      *
24931 *    input:       PA1,PA2   input momentum vectors                     *
24932 *                 XM1,2     desired masses of particles afterwards     *
24933 *                 P1,P2     changed momentum vectors                   *
24934 *                                                                      *
24935 * The original version is written by R. Engel.                         *
24936 * This version dated 12.12.94 is modified by S. Roesler.               *
24937 ************************************************************************
24938
24939       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
24940       SAVE
24941
24942       PARAMETER ( LINP = 10 ,
24943      &            LOUT = 6 ,
24944      &            LDAT = 9 )
24945
24946       PARAMETER (TINY10=1.0D-10,ONE=1.0D0,ZERO=0.0D0)
24947
24948       DIMENSION PA1(4),PA2(4),P1(4),P2(4)
24949
24950       IREJ = 0
24951
24952 * Lorentz transformation into system CMS
24953       PX  = PA1(1)+PA2(1)
24954       PY  = PA1(2)+PA2(2)
24955       PZ  = PA1(3)+PA2(3)
24956       EE  = PA1(4)+PA2(4)
24957       XPTOT = SQRT(PX**2+PY**2+PZ**2)
24958       XMS   = (EE-XPTOT)*(EE+XPTOT)
24959       IF(XMS.LT.(XM1+XM2)**2) THEN
24960 C        WRITE(LOUT,'(3E12.4)')XMS,XM1,XM2
24961          GOTO 9999
24962       ENDIF
24963       XMS = SQRT(XMS)
24964       BGX = PX/XMS
24965       BGY = PY/XMS
24966       BGZ = PZ/XMS
24967       GAM = EE/XMS
24968       CALL DT_DALTRA(GAM,-BGX,-BGY,-BGZ,PA1(1),PA1(2),PA1(3),
24969      &           PA1(4),PTOT1,P1(1),P1(2),P1(3),P1(4))
24970 * rotation angles
24971       COD = P1(3)/PTOT1
24972 C     SID = SQRT((ONE-COD)*(ONE+COD))
24973       PPT = SQRT(P1(1)**2+P1(2)**2)
24974       SID = PPT/PTOT1
24975       COF = ONE
24976       SIF = ZERO
24977       IF(PTOT1*SID.GT.TINY10) THEN
24978          COF   = P1(1)/(SID*PTOT1)
24979          SIF   = P1(2)/(SID*PTOT1)
24980          ANORF = SQRT(COF*COF+SIF*SIF)
24981          COF   = COF/ANORF
24982          SIF   = SIF/ANORF
24983       ENDIF
24984 * new CM momentum and energies (for masses XM1,XM2)
24985       XM12 = SIGN(XM1**2,XM1)
24986       XM22 = SIGN(XM2**2,XM2)
24987       SS   = XMS**2
24988       PCMP = DT_YLAMB(SS,XM12,XM22)/(2.D0*XMS)
24989       EE1  = SQRT(XM12+PCMP**2)
24990       EE2  = XMS-EE1
24991 * back rotation
24992       MODE = 1
24993       CALL DT_MYTRAN(MODE,ZERO,ZERO,PCMP,COD,SID,COF,SIF,XX,YY,ZZ)
24994       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,XX,YY,ZZ,EE1,
24995      &            PTOT1,P1(1),P1(2),P1(3),P1(4))
24996       CALL DT_DALTRA(GAM,BGX,BGY,BGZ,-XX,-YY,-ZZ,EE2,
24997      &            PTOT2,P2(1),P2(2),P2(3),P2(4))
24998 * check consistency
24999       DEL = XMS*0.0001D0
25000       IF (ABS(PX-P1(1)-P2(1)).GT.DEL) THEN
25001         IDEV = 1
25002       ELSEIF (ABS(PY-P1(2)-P2(2)).GT.DEL) THEN
25003         IDEV = 2
25004       ELSEIF (ABS(PZ-P1(3)-P2(3)).GT.DEL) THEN
25005         IDEV = 3
25006       ELSEIF (ABS(EE-P1(4)-P2(4)).GT.DEL) THEN
25007         IDEV = 4
25008       ELSE
25009         IDEV = 0
25010       ENDIF
25011       IF (IDEV.NE.0) THEN
25012          WRITE(LOUT,'(/1X,A,I3)')
25013      &      'MASHEL: inconsistent transformation',IDEV
25014          WRITE(LOUT,'(1X,A)') 'MASHEL: input momenta/masses:'
25015          WRITE(LOUT,'(1X,5E12.5)') (PA1(K),K=1,4),XM1
25016          WRITE(LOUT,'(1X,5E12.5)') (PA2(K),K=1,4),XM2
25017          WRITE(LOUT,'(1X,A)') 'MASHEL: output momenta:'
25018          WRITE(LOUT,'(5X,4E12.5)') (P1(K),K=1,4)
25019          WRITE(LOUT,'(5X,4E12.5)') (P2(K),K=1,4)
25020       ENDIF
25021       RETURN
25022
25023  9999 CONTINUE
25024       IREJ = 1
25025       RETURN
25026       END
25027
25028 *$ CREATE DT_DFERMI.FOR
25029 *COPY DT_DFERMI
25030 *
25031 *===dfermi=============================================================*
25032 *
25033       SUBROUTINE DT_DFERMI(GPART)
25034
25035 ************************************************************************
25036 * Find largest of three random numbers.                                *
25037 ************************************************************************
25038
25039       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25040       SAVE
25041
25042       DIMENSION G(3)
25043
25044       DO 10 I=1,3
25045         G(I)=DT_RNDM(GPART)
25046    10 CONTINUE
25047       IF (G(3).LT.G(2)) GOTO 40
25048       IF (G(3).LT.G(1)) GOTO 30
25049       GPART = G(3)
25050    20 RETURN
25051    30 GPART = G(1)
25052       GOTO 20
25053    40 IF (G(2).LT.G(1)) GOTO 30
25054       GPART = G(2)
25055       GOTO 20
25056
25057       END
25058
25059 ************************************************************************
25060 *                                                                      *
25061 *         2) Handling of parton flavors and particle indices           *
25062 *                                                                      *
25063 ************************************************************************
25064 *$ CREATE IDT_IPDG2B.FOR
25065 *COPY IDT_IPDG2B
25066 *
25067 *===ipdg2b=============================================================*
25068 *
25069       INTEGER FUNCTION IDT_IPDG2B(ID,NN,MODE)
25070
25071 ************************************************************************
25072 *                                                                      *
25073 *     conversion of quark numbering scheme                             *
25074 *                                                                      *
25075 *     input:   PDG parton numbering                                    *
25076 *              for diquarks:  NN number of the constituent quark       *
25077 *                             (e.g. ID=2301,NN=1 -> ICONV2=1)          *
25078 *                                                                      *
25079 *     output:  BAMJET particle codes                                   *
25080 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25081 *              2 d     8 a-d             -2 a-d                        *
25082 *              3 s     9 a-s             -3 a-s                        *
25083 *              4 c    10 a-c             -4 a-c                        *
25084 *                                                                      *
25085 * This is a modified version of ICONV2 written by R. Engel.            *
25086 * This version dated 13.12.94 is written by S. Roesler.                *
25087 ************************************************************************
25088
25089       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25090       SAVE
25091
25092       PARAMETER ( LINP = 10 ,
25093      &            LOUT = 6 ,
25094      &            LDAT = 9 )
25095
25096       IDA = ABS(ID)
25097 * diquarks
25098       IF (IDA.GT.6) THEN
25099         KF  = 3
25100         IF (IDA.GE.1000) KF = 4
25101         IDA = IDA/(10**(KF-NN))
25102         IDA = MOD(IDA,10)
25103       ENDIF
25104 * exchange up and dn quarks
25105       IF (IDA.EQ.1) THEN
25106         IDA = 2
25107       ELSEIF (IDA.EQ.2) THEN
25108         IDA = 1
25109       ENDIF
25110 * antiquarks
25111       IF (ID.LT.0) THEN
25112          IF (MODE.EQ.1) THEN
25113             IDA = IDA+6
25114          ELSE
25115             IDA = -IDA
25116          ENDIF
25117       ENDIF
25118       IDT_IPDG2B = IDA
25119
25120       RETURN
25121       END
25122
25123 *$ CREATE IDT_IB2PDG.FOR
25124 *COPY IDT_IB2PDG
25125 *
25126 *===ib2pdg=============================================================*
25127 *
25128       INTEGER FUNCTION IDT_IB2PDG(ID1,ID2,MODE)
25129
25130 ************************************************************************
25131 *                                                                      *
25132 *     conversion of quark numbering scheme                             *
25133 *                                                                      *
25134 *     input:   BAMJET particle codes                                   *
25135 *              1 u     7 a-u   (MODE=1)  -1 a-u   (MODE=2)             *
25136 *              2 d     8 a-d             -2 a-d                        *
25137 *              3 s     9 a-s             -3 a-s                        *
25138 *              4 c    10 a-c             -4 a-c                        *
25139 *                                                                      *
25140 *     output:  PDG parton numbering                                    *
25141 *                                                                      *
25142 * This version dated 13.12.94 is written by S. Roesler.                *
25143 ************************************************************************
25144
25145       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25146       SAVE
25147
25148       PARAMETER ( LINP = 10 ,
25149      &            LOUT = 6 ,
25150      &            LDAT = 9 )
25151
25152       DIMENSION IHKKQ(-6:6),IHKKQQ(-3:3,-3:3)
25153       DATA IHKKQ/-6,-5,-4,-3,-1,-2,0,2,1,3,4,5,6/
25154       DATA IHKKQQ/-3303,-3103,-3203,0,0,0,0, -3103,-1103,-2103,0,0,0,0,
25155      &-3203,-2103,-2203,0,0,0,0, 0,0,0,0,0,0,0, 0,0,0,0,2203,2103,3203,
25156      &0,0,0,0,2103,1103,3103, 0,0,0,0,3203,3103,3303/
25157
25158       IDA = ID1
25159       IDB = ID2
25160       IF (MODE.EQ.1) THEN
25161          IF (ID1.GT.6) IDA = -(ID1-6)
25162          IF (ID2.GT.6) IDB = -(ID2-6)
25163       ENDIF
25164       IF (ID2.EQ.0) THEN
25165          IDT_IB2PDG = IHKKQ(IDA)
25166       ELSE
25167          IDT_IB2PDG = IHKKQQ(IDA,IDB)
25168       ENDIF
25169
25170       RETURN
25171       END
25172
25173 *$ CREATE IDT_IQUARK.FOR
25174 *COPY IDT_IQUARK
25175 *
25176 *===ipdgqu=============================================================*
25177 *
25178       INTEGER FUNCTION IDT_IQUARK(K,IDBAMJ)
25179
25180 ************************************************************************
25181 *                                                                      *
25182 *     quark contents according to PDG conventions                      *
25183 *     (random selection in case of quark mixing)                       *
25184 *                                                                      *
25185 *     input:   IDBAMJ BAMJET particle code                             *
25186 *              K      1..3   quark number                              *
25187 *                                                                      *
25188 *     output:  1   d  (anti --> neg.)                                  *
25189 *              2   u                                                   *
25190 *              3   s                                                   *
25191 *              4   c                                                   *
25192 *                                                                      *
25193 * This version written by R. Engel.                                    *
25194 ************************************************************************
25195
25196       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25197       SAVE
25198
25199       IQ = IDT_IBJQUA(K,IDBAMJ)
25200 * quark-antiquark
25201       IF (IQ.GT.6) THEN
25202          IQ = 6-IQ
25203       ENDIF
25204 * exchange of up and down
25205       IF (ABS(IQ).EQ.1) THEN
25206          IQ = SIGN(2,IQ)
25207       ELSEIF (ABS(IQ).EQ.2) THEN
25208          IQ = SIGN(1,IQ)
25209       ENDIF
25210       IDT_IQUARK = IQ
25211
25212       RETURN
25213       END
25214
25215 *$ CREATE IDT_IBJQUA.FOR
25216 *COPY IDT_IBJQUA
25217 *
25218 *===ibamq==============================================================*
25219 *
25220       INTEGER FUNCTION IDT_IBJQUA(K,IDBAMJ)
25221
25222 ************************************************************************
25223 *                                                                      *
25224 *     quark contents according to BAMJET conventions                   *
25225 *     (random selection in case of quark mixing)                       *
25226 *                                                                      *
25227 *     input:   IDBAMJ BAMJET particle code                             *
25228 *              K      1..3   quark number                              *
25229 *                                                                      *
25230 *     output:  1   u      7   u bar                                    *
25231 *              2   d      8   d bar                                    *
25232 *              3   s      9   s bar                                    *
25233 *              4   c     10   c bar                                    *
25234 *                                                                      *
25235 * This version written by R. Engel.                                    *
25236 ************************************************************************
25237
25238       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25239       SAVE
25240
25241       DIMENSION ITAB(3,210)
25242       DATA ((ITAB(I,K),I=1,3),K=1,30) /
25243      &    1,  1,  2,   7,  7,  8,   0,  0,  0,
25244      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25245      &    0,  0,  0,   1,  2,  2,   7,  8,  8,
25246 *sr 10.1.94
25247 C    &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25248      &    0,  0,  0,   0,  0,  0,   3,  8,  0,
25249 *
25250      &    1,  8,  0,   2,  7,  0,   1,  9,  0,
25251 *sr 10.1.94
25252 C    &    3,  7,  0,   0,  0,  0,   0,  0,  0,
25253      &    3,  7,  0,   3,  1,  2,   9,  7,  8,
25254 *sr 10.1.94
25255 C    &    0,  0,  0,   2,  2,  3,   1,  1,  3,
25256      &    2,  9,  0,   2,  2,  3,   1,  1,  3,
25257 *
25258      &    1,  2,  3, 201,202,  0,   2,  9,  0,
25259      &    3,  8,  0,   0,  0,  0,   0,  0,  0,
25260      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25261       DATA ((ITAB(I,K),I=1,3),K=31,60) /
25262      &    3,  9,  0,   1,  8,  0, 203,204,  0,
25263      &    2,  7,  0,   0,  0,  0,   1,  9,  0,
25264      &    2,  9,  0,   3,  7,  0,   3,  8,  0,
25265      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25266      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25267      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25268      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25269      &    0,  0,  0,   1,  1,  1,   1,  1,  2,
25270      &    1,  2,  2,   2,  2,  2,   0,  0,  0,
25271      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25272       DATA ((ITAB(I,K),I=1,3),K=61,90) /
25273      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25274      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25275      &    7,  7,  7,   7,  7,  8,   7,  8,  8,
25276      &    8,  8,  8,   0,  0,  0,   0,  0,  0,
25277      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25278      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25279      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25280      &    0,  0,  0,   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       DATA ((ITAB(I,K),I=1,3),K=91,120) /
25284      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25285      &    0,  0,  0,   0,  0,  0,   3,  9,  0,
25286      &    1,  3,  3,   2,  3,  3,   7,  7,  9,
25287      &    7,  8,  9,   8,  8,  9,   7,  9,  9,
25288      &    8,  9,  9,   1,  1,  3,   1,  2,  3,
25289      &    2,  2,  3,   1,  3,  3,   2,  3,  3,
25290      &    3,  3,  3,   7,  7,  9,   7,  8,  9,
25291      &    8,  8,  9,   7,  9,  9,   8,  9,  9,
25292      &    9,  9,  9,   4,  7,  0,   4,  8,  0,
25293      &    2, 10,  0,   1, 10,  0,   4,  9,  0 /
25294       DATA ((ITAB(I,K),I=1,3),K=121,150) /
25295      &    3, 10,  0,   4, 10,  0,   4,  7,  0,
25296      &    4,  8,  0,   2, 10,  0,   1, 10,  0,
25297      &    4,  9,  0,   3, 10,  0,   4, 10,  0,
25298      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25299      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25300      &    0,  0,  0,   1,  2,  4,   1,  3,  4,
25301      &    2,  3,  4,   1,  1,  4,   0,  0,  0,
25302      &    2,  2,  4,   0,  0,  0,   0,  0,  0,
25303      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25304      &    3,  4,  4,   7,  8, 10,   7,  9, 10 /
25305       DATA ((ITAB(I,K),I=1,3),K=151,180) /
25306      &    8,  9, 10,   7,  7, 10,   0,  0,  0,
25307      &    8,  8, 10,   0,  0,  0,   0,  0,  0,
25308      &    9,  9, 10,   7, 10, 10,   8, 10, 10,
25309      &    9, 10, 10,   1,  1,  4,   1,  2,  4,
25310      &    2,  2,  4,   1,  3,  4,   2,  3,  4,
25311      &    3,  3,  4,   1,  4,  4,   2,  4,  4,
25312      &    3,  4,  4,   4,  4,  4,   7,  7, 10,
25313      &    7,  8, 10,   8,  8, 10,   7,  9, 10,
25314      &    8,  9, 10,   9,  9, 10,   7, 10, 10,
25315      &    8, 10, 10,   9, 10, 10,  10, 10, 10 /
25316       DATA ((ITAB(I,K),I=1,3),K=181,210) /
25317      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25318      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25319      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25320      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
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,   1,  7,  0,
25324      &    2,  8,  0,   1,  7,  0,   2,  8,  0,
25325      &    0,  0,  0,   0,  0,  0,   0,  0,  0,
25326      &    0,  0,  0,   0,  0,  0,   0,  0,  0 /
25327       DATA IDOLD /0/
25328
25329       ONE = 1.0D0
25330       IF (ITAB(1,IDBAMJ).LE.200) THEN
25331          ID = ITAB(K,IDBAMJ)
25332       ELSE
25333          IF(IDOLD.NE.IDBAMJ) THEN
25334             IT = AINT((ITAB(2,IDBAMJ)-ITAB(1,IDBAMJ)+0.999999D0)*
25335      &           DT_RNDM(ONE)+ITAB(1,IDBAMJ))
25336         ELSE
25337            IDOLD = 0
25338         ENDIF
25339         ID = ITAB(K,IT)
25340       ENDIF
25341       IDOLD  = IDBAMJ
25342       IDT_IBJQUA = ID
25343
25344       RETURN
25345       END
25346
25347 *$ CREATE IDT_ICIHAD.FOR
25348 *COPY IDT_ICIHAD
25349 *
25350 *===icihad=============================================================*
25351 *
25352       INTEGER FUNCTION IDT_ICIHAD(MCIND)
25353
25354 ************************************************************************
25355 * Conversion of particle index PDG proposal --> BAMJET-index scheme    *
25356 * This is a completely new version dated 25.10.95.                     *
25357 * Renamed to be not in conflict with the modified PHOJET-version       *
25358 ************************************************************************
25359
25360       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25361       SAVE
25362
25363 * hadron index conversion (BAMJET <--> PDG)
25364       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25365      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25366      &                IAMCIN(210)
25367
25368       IDT_ICIHAD = 0
25369       KPDG   = ABS(MCIND)
25370       IF ((KPDG.EQ.0).OR.(KPDG.GT.70000)) RETURN
25371       IF (MCIND.LT.0) THEN
25372          JSIGN = 1
25373       ELSE
25374          JSIGN = 2
25375       ENDIF
25376       IF (KPDG.GE.10000) THEN
25377          DO 1 I=1,19
25378             IDT_ICIHAD = IBAM5(JSIGN,I)
25379             IF (IPDG5(JSIGN,I).EQ.MCIND) GOTO 5
25380             IDT_ICIHAD = 0
25381     1    CONTINUE
25382       ELSEIF (KPDG.GE.1000) THEN
25383          DO 2 I=1,29
25384             IDT_ICIHAD = IBAM4(JSIGN,I)
25385             IF (IPDG4(JSIGN,I).EQ.MCIND) GOTO 5
25386             IDT_ICIHAD = 0
25387     2    CONTINUE
25388       ELSEIF (KPDG.GE.100) THEN
25389          DO 3 I=1,22
25390             IDT_ICIHAD = IBAM3(JSIGN,I)
25391             IF (IPDG3(JSIGN,I).EQ.MCIND) GOTO 5
25392             IDT_ICIHAD = 0
25393     3    CONTINUE
25394       ELSEIF (KPDG.GE.10) THEN
25395          DO 4 I=1,7
25396             IDT_ICIHAD = IBAM2(JSIGN,I)
25397             IF (IPDG2(JSIGN,I).EQ.MCIND) GOTO 5
25398             IDT_ICIHAD = 0
25399     4    CONTINUE
25400       ENDIF
25401     5 CONTINUE
25402
25403       RETURN
25404       END
25405
25406 *$ CREATE IDT_IPDGHA.FOR
25407 *COPY IDT_IPDGHA
25408 *
25409 *===ipdgha=============================================================*
25410 *
25411       INTEGER FUNCTION IDT_IPDGHA(MCIND)
25412
25413 ************************************************************************
25414 * Conversion of particle index BAMJET-index scheme --> PDG proposal    *
25415 * Adopted from the original by S. Roesler. This version dated 12.5.95  *
25416 * Renamed to be not in conflict with the modified PHOJET-version       *
25417 ************************************************************************
25418
25419       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25420       SAVE
25421
25422 * hadron index conversion (BAMJET <--> PDG)
25423       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
25424      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
25425      &                IAMCIN(210)
25426
25427       IDT_IPDGHA = IAMCIN(MCIND)
25428
25429       RETURN
25430       END
25431
25432 *$ CREATE DT_FLAHAD.FOR
25433 *COPY DT_FLAHAD
25434 *
25435 *===flahad=============================================================*
25436 *
25437       SUBROUTINE DT_FLAHAD(ID,IF1,IF2,IF3)
25438
25439 ************************************************************************
25440 * sampling of FLAvor composition for HADrons/photons                   *
25441 *              ID         BAMJET-id of hadron                          *
25442 *              IF1,2,3    flavor content                               *
25443 *                         (u,d,s: 1,2,3;  au,ad,as: -1,-1,-3)          *
25444 * Note:  -  u,d numbering as in BAMJET                                 *
25445 *        -  ID .le. 30 !!                                              *
25446 * This version dated 12.03.96 is written by S. Roesler                 *
25447 ************************************************************************
25448
25449       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25450       SAVE
25451
25452 * auxiliary common for reggeon exchange (DTUNUC 1.x)
25453       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
25454      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
25455      &                IQTCHR(-6:6),MQUARK(3,39)
25456
25457       DIMENSION JSEL(3,6)
25458       DATA JSEL/ 1,2,3,  2,3,1,  3,1,2,  1,3,2,   2,1,3,   3,2,1/
25459
25460       ONE = 1.0D0
25461       IF (ID.EQ.7) THEN
25462 * photon (charge dependent flavour sampling)
25463          K = INT(DT_RNDM(ONE)*6.D0+1.D0)
25464          IF (K.LE.4) THEN
25465             IF1 = 2
25466             IF2 = -2
25467          ELSE IF(K.EQ.5) THEN
25468             IF1 = 1
25469             IF2 = -1
25470          ELSE
25471             IF1 = 3
25472             IF2 = -3
25473          ENDIF
25474          IF(DT_RNDM(ONE).LT.0.5D0) THEN
25475             K   = IF1
25476             IF1 = IF2
25477             IF2 = K
25478          ENDIF
25479          IF3 = 0
25480       ELSE
25481 * hadron
25482          IX  = INT(1.0D0+5.99999D0*DT_RNDM(ONE))
25483          IF1 = MQUARK(JSEL(1,IX),ID)
25484          IF2 = MQUARK(JSEL(2,IX),ID)
25485          IF3 = MQUARK(JSEL(3,IX),ID)
25486          IF ((IF1.EQ.0).AND.(IF3.NE.0)) THEN
25487             IF1 = IF3
25488             IF3 = 0
25489          ELSEIF ((IF2.EQ.0).AND.(IF3.NE.0)) THEN
25490             IF2 = IF3
25491             IF3 = 0
25492          ENDIF
25493       ENDIF
25494
25495       RETURN
25496       END
25497
25498 *$ CREATE IDT_MCHAD.FOR
25499 *COPY IDT_MCHAD
25500 *
25501 *===mchad==============================================================*
25502 *
25503       INTEGER FUNCTION IDT_MCHAD(ITDTU)
25504
25505 ************************************************************************
25506 * Conversion of particle index BAMJET-index scheme --> HADRIN index s. *
25507 * Adopted from the original by S. Roesler. This version dated 6.5.95   *
25508 *                                                                      *
25509 * Last change 28.12.2006 by S. Roesler.                                *
25510 ************************************************************************
25511
25512       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25513       SAVE
25514
25515       DIMENSION ITRANS(210)
25516       DATA ITRANS / 1, 2, -1, -1, -1, -1, -1, 8, 9, -1, -1, 24, 13, 14,
25517      &15, 16, 8, 9, 25, 8, 1, 8, 23, 24, 25, -1, -1, -1, -1, -1, 23, 13,
25518      &23, 14, 23, 15, 24, 16, 25, 15, 24, 16, 25, 15, 24, 16, 25, 1, 8,
25519      &8, 8, 1, 1, 1, 8, 8, 1, 1, 8, 8, 1, 8, 1, 8, 1, 8, 2, 2, 9, 9, 2,
25520      &2, 9, 9, 2, 9, 1, 13, 23, 14, 1, 1, 8, 8, 1, 1, 23, 14, 1, 8, 1,
25521      &8, 1, 8, 23, 23, 8, 8, 2, 9, 9, 9, 9, 1, 8, 8, 8, 8, 8, 2, 9, 9,
25522      &9, 9, 9, 85*- 1,7*-1,1,8,-1/
25523
25524       IF ( ITDTU .GT. 0 ) THEN
25525          IDT_MCHAD = ITRANS(ITDTU)
25526       ELSE
25527          IDT_MCHAD = -1
25528       END IF
25529
25530       RETURN
25531       END
25532
25533 ************************************************************************
25534 *                                                                      *
25535 *   3) Energy-momentum and quantum number conservation check routines  *
25536 *                                                                      *
25537 ************************************************************************
25538 *$ CREATE DT_EMC1.FOR
25539 *COPY DT_EMC1
25540 *
25541 *===emc1===============================================================*
25542 *
25543       SUBROUTINE DT_EMC1(PP1,PP2,PT1,PT2,MODE,IPOS,IREJ)
25544
25545 ************************************************************************
25546 * This version dated 15.12.94 is written by S. Roesler                 *
25547 ************************************************************************
25548
25549       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25550       SAVE
25551
25552       PARAMETER ( LINP = 10 ,
25553      &            LOUT = 6 ,
25554      &            LDAT = 9 )
25555
25556       PARAMETER (TINY10=1.0D-10)
25557
25558       DIMENSION PP1(4),PP2(4),PT1(4),PT2(4)
25559
25560       IREJ = 0
25561
25562       IF ((MODE.EQ.0).OR.(ABS(MODE).GT.3))
25563      &   WRITE(LOUT,'(1X,A,I6)')'EMC1: not supported MODE ',MODE
25564
25565       IF ((MODE.GT.0).AND.(MODE.LT.3)) THEN
25566          IF (MODE.EQ.1) THEN
25567             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),1,IDUM,IDUM)
25568          ELSEIF (MODE.EQ.2) THEN
25569             CALL DT_EVTEMC(PP1(1),PP1(2),PP1(3),PP1(4),2,IDUM,IDUM)
25570          ENDIF
25571          CALL DT_EVTEMC(PP2(1),PP2(2),PP2(3),PP2(4),2,IDUM,IDUM)
25572          CALL DT_EVTEMC(PT1(1),PT1(2),PT1(3),PT1(4),2,IDUM,IDUM)
25573          CALL DT_EVTEMC(PT2(1),PT2(2),PT2(3),PT2(4),2,IDUM,IDUM)
25574       ELSEIF (MODE.LT.0) THEN
25575          IF (MODE.EQ.-1) THEN
25576             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),1,IDUM,IDUM)
25577          ELSEIF (MODE.EQ.-2) THEN
25578             CALL DT_EVTEMC(-PP1(1),-PP1(2),-PP1(3),-PP1(4),2,IDUM,IDUM)
25579          ENDIF
25580          CALL DT_EVTEMC(-PP2(1),-PP2(2),-PP2(3),-PP2(4),2,IDUM,IDUM)
25581          CALL DT_EVTEMC(-PT1(1),-PT1(2),-PT1(3),-PT1(4),2,IDUM,IDUM)
25582          CALL DT_EVTEMC(-PT2(1),-PT2(2),-PT2(3),-PT2(4),2,IDUM,IDUM)
25583       ENDIF
25584
25585       IF (ABS(MODE).EQ.3) THEN
25586          CALL DT_EVTEMC(DUM,DUM,DUM,DUM,3,IPOS,IREJ1)
25587          IF (IREJ1.NE.0) GOTO 9999
25588       ENDIF
25589       RETURN
25590
25591  9999 CONTINUE
25592       IREJ = 1
25593       RETURN
25594       END
25595
25596 *$ CREATE DT_EMC2.FOR
25597 *COPY DT_EMC2
25598 *
25599 *===emc2===============================================================*
25600 *
25601       SUBROUTINE DT_EMC2(IP1,IP2,IP3,IP4,IP5,MP,IN1,IN2,IN3,IN4,IN5,MN,
25602      &                                                MODE,IPOS,IREJ)
25603
25604 ************************************************************************
25605 *             MODE = 1   energy-momentum cons. check                   *
25606 *                  = 2   flavor-cons. check                            *
25607 *                  = 3   energy-momentum & flavor cons. check          *
25608 *                  = 4   energy-momentum & charge cons. check          *
25609 *                  = 5   energy-momentum & flavor & charge cons. check *
25610 * This version dated 16.01.95 is written by S. Roesler                 *
25611 ************************************************************************
25612
25613       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25614       SAVE
25615
25616       PARAMETER ( LINP = 10 ,
25617      &            LOUT = 6 ,
25618      &            LDAT = 9 )
25619
25620       PARAMETER (TINY10=1.0D-10,ZERO=0.0D0)
25621
25622 * event history
25623
25624       PARAMETER (NMXHKK=200000)
25625
25626       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25627      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25628      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25629
25630 * extended event history
25631       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
25632      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
25633      &                IHIST(2,NMXHKK)
25634
25635       IREJ  = 0
25636       IREJ1 = 0
25637       IREJ2 = 0
25638       IREJ3 = 0
25639
25640       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25641      &                CALL DT_EVTEMC(ZERO,ZERO,ZERO,ZERO,1,IDUM,IDUM)
25642       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25643      &                                CALL DT_EVTFLC(0,IDUM,1,IDUM,IDUM)
25644       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,1,IDUM,IDUM)
25645       DO 1 I=1,NHKK
25646          IF ((ISTHKK(I).EQ.IP1).OR.(ISTHKK(I).EQ.IP2).OR.
25647      &       (ISTHKK(I).EQ.IP3).OR.(ISTHKK(I).EQ.IP4).OR.
25648      &       (ISTHKK(I).EQ.IP5))                          THEN
25649             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25650      &                                    .OR.(MODE.EQ.5))
25651      &      CALL DT_EVTEMC(PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
25652      &                                               2,IDUM,IDUM)
25653             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25654      &         CALL DT_EVTFLC(IDHKK(I),MP,2,IDUM,IDUM)
25655             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25656      &                            CALL DT_EVTCHG(IDHKK(I),2,IDUM,IDUM)
25657          ENDIF
25658          IF ((ISTHKK(I).EQ.IN1).OR.(ISTHKK(I).EQ.IN2).OR.
25659      &       (ISTHKK(I).EQ.IN3).OR.(ISTHKK(I).EQ.IN4).OR.
25660      &       (ISTHKK(I).EQ.IN5))                          THEN
25661             IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4)
25662      &                                    .OR.(MODE.EQ.5))
25663      &      CALL DT_EVTEMC(-PHKK(1,I),-PHKK(2,I),-PHKK(3,I),-PHKK(4,I),
25664      &                                                   2,IDUM,IDUM)
25665             IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25666      &         CALL DT_EVTFLC(IDHKK(I),MN,-2,IDUM,IDUM)
25667             IF ((MODE.EQ.4).OR.(MODE.EQ.5))
25668      &                            CALL DT_EVTCHG(IDHKK(I),-2,IDUM,IDUM)
25669          ENDIF
25670     1 CONTINUE
25671       IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.(MODE.EQ.4).OR.(MODE.EQ.5))
25672      &   CALL DT_EVTEMC(DUM,DUM,DUM,DUM,5,IPOS,IREJ1)
25673       IF ((MODE.EQ.2).OR.(MODE.EQ.3).OR.(MODE.EQ.5))
25674      &   CALL DT_EVTFLC(0,IDUM,3,IPOS,IREJ2)
25675       IF ((MODE.EQ.4).OR.(MODE.EQ.5)) CALL DT_EVTCHG(IDUM,3,IPOS,IREJ3)
25676       IF ((IREJ1.NE.0).OR.(IREJ2.NE.0).OR.(IREJ3.NE.0)) GOTO 9999
25677
25678       RETURN
25679
25680  9999 CONTINUE
25681       IREJ = 1
25682       RETURN
25683       END
25684
25685 *$ CREATE DT_EVTEMC.FOR
25686 *COPY DT_EVTEMC
25687 *
25688 *===evtemc=============================================================*
25689 *
25690       SUBROUTINE DT_EVTEMC(PXIO,PYIO,PZIO,EIO,IMODE,IPOS,IREJ)
25691
25692 ************************************************************************
25693 * This version dated 13.12.94 is written by S. Roesler                 *
25694 ************************************************************************
25695
25696       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25697       SAVE
25698
25699       PARAMETER ( LINP = 10 ,
25700      &            LOUT = 6 ,
25701      &            LDAT = 9 )
25702
25703       PARAMETER (TINY1=1.0D-1,TINY2=1.0D-2,TINY4=1.0D-4,TINY10=1.0D-10,
25704      &           ZERO=0.0D0)
25705
25706 * event history
25707
25708       PARAMETER (NMXHKK=200000)
25709
25710       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25711      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25712      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25713
25714 * flags for input different options
25715       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
25716       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
25717      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
25718
25719       IREJ = 0
25720
25721       MODE = IMODE
25722       CHKLEV = TINY10
25723       IF (MODE.EQ.4) THEN
25724          CHKLEV = TINY2
25725          MODE   = 3
25726       ELSEIF (MODE.EQ.5) THEN
25727          CHKLEV = TINY1
25728          MODE   = 3
25729       ELSEIF (MODE.EQ.-1) THEN
25730          CHKLEV = EIO
25731          MODE   = 3
25732       ENDIF
25733
25734       IF (ABS(MODE).EQ.3) THEN
25735          PXDEV = PX
25736          PYDEV = PY
25737          PZDEV = PZ
25738          EDEV  = E
25739          IF ((IFRAG(1).EQ.2).AND.(CHKLEV.LT.TINY4)) CHKLEV = TINY4
25740          IF ((ABS(PXDEV).GT.CHKLEV).OR.(ABS(PYDEV).GT.CHKLEV).OR.
25741      &       (ABS(PZDEV).GT.CHKLEV).OR.(ABS(EDEV).GT.CHKLEV)) THEN
25742             IF (IOULEV(2).GT.0) WRITE(LOUT,'(1X,A,I4,A,I8,A,/,4G10.3)')
25743      &         'EVTEMC: energy-momentum cons. failure at pos. ',IPOS,
25744      &         '  event  ',NEVHKK,
25745      &         ' ! ',PXDEV,PYDEV,PZDEV,EDEV
25746             PX   = 0.0D0
25747             PY   = 0.0D0
25748             PZ   = 0.0D0
25749             E    = 0.0D0
25750             GOTO 9999
25751          ENDIF
25752          PX   = 0.0D0
25753          PY   = 0.0D0
25754          PZ   = 0.0D0
25755          E    = 0.0D0
25756          RETURN
25757       ENDIF
25758
25759       IF (MODE.EQ.1) THEN
25760          PX = 0.0D0
25761          PY = 0.0D0
25762          PZ = 0.0D0
25763          E  = 0.0D0
25764       ENDIF
25765
25766       PX = PX+PXIO
25767       PY = PY+PYIO
25768       PZ = PZ+PZIO
25769       E  = E+EIO
25770
25771       RETURN
25772
25773  9999 CONTINUE
25774       IREJ = 1
25775       RETURN
25776       END
25777
25778 *$ CREATE DT_EVTFLC.FOR
25779 *COPY DT_EVTFLC
25780 *
25781 *===evtflc=============================================================*
25782 *
25783       SUBROUTINE DT_EVTFLC(ID,ID1,MODE,IPOS,IREJ)
25784
25785 ************************************************************************
25786 * Flavor conservation check.                                           *
25787 *        ID       identity of particle                                 *
25788 *        ID1 = 1  ID for q,aq,qq,aqaq in PDG-numbering scheme          *
25789 *            = 2  ID for particle/resonance in BAMJET numbering scheme *
25790 *            = 3  ID for particle/resonance in PDG    numbering scheme *
25791 *        MODE = 1 initialization and add ID                            *
25792 *             =-1 initialization and subtract ID                       *
25793 *             = 2 add ID                                               *
25794 *             =-2 subtract ID                                          *
25795 *             = 3 check flavor cons.                                   *
25796 *        IPOS     flag to give position of call of EVTFLC to output    *
25797 *                 unit in case of violation                            *
25798 * This version dated 10.01.95 is written by S. Roesler                 *
25799 ************************************************************************
25800
25801       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25802       SAVE
25803
25804       PARAMETER ( LINP = 10 ,
25805      &            LOUT = 6 ,
25806      &            LDAT = 9 )
25807
25808       PARAMETER (TINY10=1.0D-10)
25809
25810       IREJ = 0
25811
25812       IF (MODE.EQ.3) THEN
25813          IF (IFL.NE.0) THEN
25814             WRITE(LOUT,'(1X,A,I3,A,I3)')
25815      &         'EVTFLC: flavor-conservation failure at pos. ',IPOS,
25816      &         ' !  IFL = ',IFL
25817             IFL = 0
25818             GOTO 9999
25819          ENDIF
25820          IFL = 0
25821          RETURN
25822       ENDIF
25823
25824       IF (MODE.EQ.1) IFL = 0
25825       IF (ID.EQ.0)   RETURN
25826
25827       IF (ID1.EQ.1) THEN
25828          IDD = ABS(ID)
25829          NQ  = 1
25830          IF ((IDD.GE.100).AND.(IDD.LT.1000)) NQ = 2
25831          IF (IDD.GE.1000) NQ = 3
25832          DO 1 I=1,NQ
25833             IFBAM = IDT_IPDG2B(ID,I,2)
25834             IF (ABS(IFBAM).EQ.1) THEN
25835                IFBAM = SIGN(2,IFBAM)
25836             ELSEIF (ABS(IFBAM).EQ.2) THEN
25837                IFBAM = SIGN(1,IFBAM)
25838             ENDIF
25839             IF (MODE.GT.0) THEN
25840                IFL = IFL+IFBAM
25841             ELSE
25842                IFL = IFL-IFBAM
25843             ENDIF
25844     1    CONTINUE
25845          RETURN
25846       ENDIF
25847
25848       IDD = ID
25849       IF (ID1.EQ.3) IDD = IDT_ICIHAD(ID)
25850       IF ((ID1.EQ.2).OR.(ID1.EQ.3)) THEN
25851          DO 2 I=1,3
25852             IF (MODE.GT.0) THEN
25853                IFL = IFL+IDT_IQUARK(I,IDD)
25854             ELSE
25855                IFL = IFL-IDT_IQUARK(I,IDD)
25856             ENDIF
25857     2    CONTINUE
25858       ENDIF
25859       RETURN
25860
25861  9999 CONTINUE
25862       IREJ = 1
25863       RETURN
25864       END
25865
25866 *$ CREATE DT_EVTCHG.FOR
25867 *COPY DT_EVTCHG
25868 *
25869 *===evtchg=============================================================*
25870 *
25871       SUBROUTINE DT_EVTCHG(ID,MODE,IPOS,IREJ)
25872
25873 ************************************************************************
25874 * Charge conservation check.                                           *
25875 *        ID       identity of particle (PDG-numbering scheme)          *
25876 *        MODE = 1 initialization                                       *
25877 *             =-2 subtract ID-charge                                   *
25878 *             = 2 add ID-charge                                        *
25879 *             = 3 check charge cons.                                   *
25880 *        IPOS     flag to give position of call of EVTCHG to output    *
25881 *                 unit in case of violation                            *
25882 * This version dated 10.01.95 is written by S. Roesler                 *
25883 * Last change: s.r. 21.01.01                                           *
25884 ************************************************************************
25885
25886       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25887       SAVE
25888
25889       PARAMETER ( LINP = 10 ,
25890      &            LOUT = 6 ,
25891      &            LDAT = 9 )
25892
25893 * event history
25894
25895       PARAMETER (NMXHKK=200000)
25896
25897       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
25898      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
25899      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
25900
25901 * particle properties (BAMJET index convention)
25902       CHARACTER*8  ANAME
25903       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
25904      &                IICH(210),IIBAR(210),K1(210),K2(210)
25905
25906       IREJ = 0
25907
25908       IF (MODE.EQ.1) THEN
25909          ICH  = 0
25910          IBAR = 0
25911          RETURN
25912       ENDIF
25913
25914       IF (MODE.EQ.3) THEN
25915          IF ((ICH.NE.0).OR.(IBAR.NE.0)) THEN
25916             WRITE(LOUT,'(1X,A,I3,A,2I3,A,I8)')
25917      &         'EVTCHG: charge/baryo.-cons. failure at pos. ',IPOS,
25918      &         '! ICH/IBAR= ',ICH,IBAR,' event ',NEVHKK
25919             ICH  = 0
25920             IBAR = 0
25921             GOTO 9999
25922          ENDIF
25923          ICH  = 0
25924          IBAR = 0
25925          RETURN
25926       ENDIF
25927
25928       IF (ID.EQ.0)   RETURN
25929
25930       IDD = IDT_ICIHAD(ID)
25931 * modification 21.1.01: use intrinsic phojet-functions to determine charge
25932 * and baryon number
25933 C     IF (IDD.GT.0) THEN
25934 C        IF (MODE.EQ.2) THEN
25935 C           ICH  = ICH+IICH(IDD)
25936 C           IBAR = IBAR+IIBAR(IDD)
25937 C        ELSEIF (MODE.EQ.-2) THEN
25938 C           ICH  = ICH-IICH(IDD)
25939 C           IBAR = IBAR-IIBAR(IDD)
25940 C        ENDIF
25941 C     ELSE
25942 C        WRITE(LOUT,'(1X,A,3I6)') 'EVTCHG: (IDD = 0 !), IDD,ID=',IDD,ID
25943 C        CALL DT_EVTOUT(4)
25944 C        STOP
25945 C     ENDIF
25946       IF (MODE.EQ.2) THEN
25947          ICH  = ICH+IPHO_CHR3(ID,1)/3
25948          IBAR = IBAR+IPHO_BAR3(ID,1)/3
25949       ELSEIF (MODE.EQ.-2) THEN
25950          ICH  = ICH-IPHO_CHR3(ID,1)/3
25951          IBAR = IBAR-IPHO_BAR3(ID,1)/3
25952       ENDIF
25953
25954       RETURN
25955
25956  9999 CONTINUE
25957       IREJ = 1
25958       RETURN
25959       END
25960
25961 ************************************************************************
25962 *                                                                      *
25963 *                 4) Transformations                                   *
25964 *                                                                      *
25965 ************************************************************************
25966 *$ CREATE DT_LTINI.FOR
25967 *COPY DT_LTINI
25968 *
25969 *===ltini==============================================================*
25970 *
25971       SUBROUTINE DT_LTINI(IDPR,IDTA,EPN0,PPN0,ECM0,MODE)
25972
25973 ************************************************************************
25974 * Initializations of Lorentz-transformations, calculation of Lorentz-  *
25975 * parameters.                                                          *
25976 * This version dated 13.11.95 is written by  S. Roesler.               *
25977 ************************************************************************
25978
25979       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
25980       SAVE
25981
25982       PARAMETER ( LINP = 10 ,
25983      &            LOUT = 6 ,
25984      &            LDAT = 9 )
25985
25986       PARAMETER (TINY10=1.0D-10,TINY3=1.0D-3,
25987      &           ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0)
25988
25989 * Lorentz-parameters of the current interaction
25990       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
25991      &                UMO,PPCM,EPROJ,PPROJ
25992
25993 * properties of photon/lepton projectiles
25994       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
25995
25996 * particle properties (BAMJET index convention)
25997       CHARACTER*8  ANAME
25998       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
25999      &                IICH(210),IIBAR(210),K1(210),K2(210)
26000
26001 * nucleon-nucleon event-generator
26002       CHARACTER*8 CMODEL
26003       LOGICAL LPHOIN
26004       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
26005
26006       Q2   = VIRT
26007       IDP  = IDPR
26008       IF (MCGENE.NE.3) THEN
26009 * lepton-projectiles and PHOJET: initialize real photon instead
26010          IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26011      &       (IDPR.EQ.10).OR.(IDPR.EQ.11).OR.
26012      &       (IDPR.EQ. 5).OR.(IDPR.EQ. 6))   THEN
26013             IDP = 7
26014             Q2  = ZERO
26015          ENDIF
26016       ENDIF
26017       IDT  = IDTA
26018       EPN  = EPN0
26019       PPN  = PPN0
26020       ECM  = ECM0
26021       AMP  = AAM(IDP)-SQRT(ABS(Q2))
26022       AMT  = AAM(IDT)
26023       AMP2 = SIGN(AMP**2,AMP)
26024       AMT2 = AMT**2
26025       IF (ECM0.GT.ZERO) THEN
26026          EPN = (ECM**2-AMP2-AMT2)/(TWO*AMT)
26027          IF (AMP2.GT.ZERO) THEN
26028             PPN = SQRT((EPN+AMP)*(EPN-AMP))
26029          ELSE
26030             PPN = SQRT(EPN**2-AMP2)
26031          ENDIF
26032       ELSE
26033          IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26034             IF (IDP.EQ.7) EPN = ABS(EPN)
26035             IF (EPN.LT.ZERO) EPN = ABS(EPN)+AMP
26036             IF (AMP2.GT.ZERO) THEN
26037                PPN = SQRT((EPN+AMP)*(EPN-AMP))
26038             ELSE
26039                PPN = SQRT(EPN**2-AMP2)
26040             ENDIF
26041          ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26042             IF (AMP2.GT.ZERO) THEN
26043                EPN = PPN*SQRT(ONE+(AMP/PPN)**2)
26044             ELSE
26045                EPN = SQRT(PPN**2+AMP2)
26046             ENDIF
26047          ENDIF
26048          ECM = SQRT(AMP2+AMT2+TWO*AMT*EPN)
26049       ENDIF
26050       UMO   = ECM
26051       EPROJ = EPN
26052       PPROJ = PPN
26053       IF (AMP2.GT.ZERO) THEN
26054          ETARG = (ECM**2-AMP2-AMT2)/(TWO*AMP)
26055          PTARG = -SQRT((ETARG+AMT)*(ETARG-AMT))
26056       ELSE
26057          ETARG = TINY10
26058          PTARG = TINY10
26059       ENDIF
26060 * photon-projectiles (get momentum in cm-frame for virtuality Q^2)
26061       IF (IDP.EQ.7) THEN
26062          PGAMM(1) = ZERO
26063          PGAMM(2) = ZERO
26064          AMGAM  = AMP
26065          AMGAM2 = AMP2
26066          IF (ECM0.GT.ZERO) THEN
26067             S = ECM0**2
26068          ELSE
26069             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26070                S = AMGAM2+AMT2+TWO*AMT*ABS(EPN0)
26071             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26072                S = AMGAM2+AMT2+TWO*AMT*SQRT(PPN0**2+AMGAM2)
26073             ENDIF
26074          ENDIF
26075          PGAMM(3) = SQRT( (S**2-TWO*AMGAM2*S-TWO*AMT2*S-TWO*AMGAM2*AMT2
26076      &                     +AMGAM2**2+AMT2**2)/(4.0D0*S) )
26077          PGAMM(4) = SQRT(AMGAM2+PGAMM(3)**2)
26078          IF (MODE.EQ.1) THEN
26079             PNUCL(1) = ZERO
26080             PNUCL(2) = ZERO
26081             PNUCL(3) = -PGAMM(3)
26082             PNUCL(4) = SQRT(S)-PGAMM(4)
26083          ENDIF
26084       ENDIF
26085       IF ((IDPR.EQ. 3).OR.(IDPR.EQ. 4).OR.
26086      &    (IDPR.EQ.10).OR.(IDPR.EQ.11))   THEN
26087          PLEPT0(1) = ZERO
26088          PLEPT0(2) = ZERO
26089 * neglect lepton masses
26090 C        AMLPT2   = AAM(IDPR)**2
26091          AMLPT2   = ZERO
26092 *
26093          IF (ECM0.GT.ZERO) THEN
26094             S = ECM0**2
26095          ELSE
26096             IF ((EPN0.NE.ZERO).AND.(PPN0.EQ.ZERO)) THEN
26097                S = AMLPT2+AMT2+TWO*AMT*ABS(EPN0)
26098             ELSEIF ((PPN0.GT.ZERO).AND.(EPN0.EQ.ZERO)) THEN
26099                S = AMLPT2+AMT2+TWO*AMT*SQRT(PPN0**2+AMLPT2)
26100             ENDIF
26101          ENDIF
26102          PLEPT0(3) = SQRT( (S**2-TWO*AMLPT2*S-TWO*AMT2*S-TWO*AMLPT2*AMT2
26103      &                     +AMLPT2**2+AMT2**2)/(4.0D0*S) )
26104          PLEPT0(4) = SQRT(AMLPT2+PLEPT0(3)**2)
26105          PNUCL(1) = ZERO
26106          PNUCL(2) = ZERO
26107          PNUCL(3) = -PLEPT0(3)
26108          PNUCL(4) = SQRT(S)-PLEPT0(4)
26109       ENDIF
26110 * Lorentz-parameter for transformation Lab. - projectile rest system
26111       IF ((IDP.EQ.7).OR.(AMP.LT.TINY10)) THEN
26112          GALAB = TINY10
26113          BGLAB = TINY10
26114          BLAB  = TINY10
26115       ELSE
26116          GALAB = EPROJ/AMP
26117          BGLAB = PPROJ/AMP
26118          BLAB  = BGLAB/GALAB
26119       ENDIF
26120 * Lorentz-parameter for transf. proj. rest sys. - nucl.-nucl. cms.
26121       IF (IDP.EQ.7) THEN
26122          GACMS(1) = TINY10
26123          BGCMS(1) = TINY10
26124       ELSE
26125          GACMS(1) = (ETARG+AMP)/UMO
26126          BGCMS(1) = PTARG/UMO
26127       ENDIF
26128 * Lorentz-parameter for transformation Lab. - nucl.-nucl. cms.
26129       GACMS(2) = (EPROJ+AMT)/UMO
26130       BGCMS(2) = PPROJ/UMO
26131       PPCM     = GACMS(2)*PPROJ-BGCMS(2)*EPROJ
26132
26133       EPN0 = EPN
26134       PPN0 = PPN
26135       ECM0 = ECM
26136
26137       RETURN
26138       END
26139
26140 *$ CREATE DT_LTRANS.FOR
26141 *COPY DT_LTRANS
26142 *
26143 *===ltrans=============================================================*
26144 *
26145       SUBROUTINE DT_LTRANS(PXI,PYI,PZI,PEI,PXO,PYO,PZO,PEO,ID,MODE)
26146
26147 ************************************************************************
26148 * Lorentz-transformations.                                             *
26149 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26150 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26151 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26152 * This version dated 01.11.95 is written by  S. Roesler.               *
26153 ************************************************************************
26154
26155       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26156       SAVE
26157
26158       PARAMETER ( LINP = 10 ,
26159      &            LOUT = 6 ,
26160      &            LDAT = 9 )
26161
26162       PARAMETER (TINY3=1.0D-3,ZERO=0.0D0,TWO=2.0D0)
26163
26164       PARAMETER (SQTINF=1.0D+15)
26165
26166 * particle properties (BAMJET index convention)
26167       CHARACTER*8  ANAME
26168       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
26169      &                IICH(210),IIBAR(210),K1(210),K2(210)
26170
26171       PXO = PXI
26172       PYO = PYI
26173       CALL DT_LTNUC(PZI,PEI,PZO,PEO,MODE)
26174
26175 * check particle mass for consistency (numerical rounding errors)
26176       PO     = SQRT(PXO*PXO+PYO*PYO+PZO*PZO)
26177       AMO2   = (PEO-PO)*(PEO+PO)
26178       AMORQ2 = AAM(ID)**2
26179       AMDIF2 = ABS(AMO2-AMORQ2)
26180       IF ((AMDIF2.GT.TINY3).AND.(PEO.LT.SQTINF).AND.(PO.GT.ZERO)) THEN
26181          DELTA = (AMORQ2-AMO2)/(TWO*(PEO+PO))
26182          PEO   = PEO+DELTA
26183          PO1   = PO -DELTA
26184          PXO   = PXO*PO1/PO
26185          PYO   = PYO*PO1/PO
26186          PZO   = PZO*PO1/PO
26187 C        WRITE(6,*) 'LTRANS corrected', AMDIF2,PZI,PEI,PZO,PEO,MODE,ID
26188       ENDIF
26189
26190       RETURN
26191       END
26192
26193 *$ CREATE DT_LTNUC.FOR
26194 *COPY DT_LTNUC
26195 *
26196 *===ltnuc==============================================================*
26197 *
26198       SUBROUTINE DT_LTNUC(PIN,EIN,POUT,EOUT,MODE)
26199
26200 ************************************************************************
26201 * Lorentz-transformations.                                             *
26202 *   PIN        longitudnal momentum       (input)                      *
26203 *   EIN        energy                     (input)                      *
26204 *   POUT       transformed long. momentum (output)                     *
26205 *   EOUT       transformed energy         (output)                     *
26206 *   MODE = 1(-1)    projectile rest syst.   --> Lab (back)             *
26207 *        = 2(-2)    projectile rest syst.   --> nucl.-nucl.cms (back)  *
26208 *        = 3(-3)    target rest syst. (=Lab)--> nucl.-nucl.cms (back)  *
26209 * This version dated 01.11.95 is written by  S. Roesler.               *
26210 ************************************************************************
26211
26212       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26213       SAVE
26214
26215       PARAMETER ( LINP = 10 ,
26216      &            LOUT = 6 ,
26217      &            LDAT = 9 )
26218
26219       PARAMETER (ZERO=0.0D0)
26220
26221 * Lorentz-parameters of the current interaction
26222       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
26223      &                UMO,PPCM,EPROJ,PPROJ
26224
26225       BDUM1 = ZERO
26226       BDUM2 = ZERO
26227       PDUM1 = ZERO
26228       PDUM2 = ZERO
26229       IF (ABS(MODE).EQ.1) THEN
26230          BG = -SIGN(BGLAB,DBLE(MODE))
26231          CALL DT_DALTRA(GALAB,BDUM1,BDUM2,-BG,PDUM1,PDUM2,PIN,EIN,
26232      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26233       ELSEIF (ABS(MODE).EQ.2) THEN
26234          BG = SIGN(BGCMS(1),DBLE(MODE))
26235          CALL DT_DALTRA(GACMS(1),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26236      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26237       ELSEIF (ABS(MODE).EQ.3) THEN
26238          BG = -SIGN(BGCMS(2),DBLE(MODE))
26239          CALL DT_DALTRA(GACMS(2),BDUM1,BDUM2,BG,PDUM1,PDUM2,PIN,EIN,
26240      &                               DUM1,DUM2,DUM3,POUT,EOUT)
26241       ELSE
26242          WRITE(LOUT,1000) MODE
26243  1000    FORMAT(1X,'LTNUC: not supported mode (MODE = ',I3,')')
26244          EOUT = EIN
26245          POUT = PIN
26246       ENDIF
26247
26248       RETURN
26249       END
26250
26251 *$ CREATE DT_DALTRA.FOR
26252 *COPY DT_DALTRA
26253 *
26254 *===daltra=============================================================*
26255 *
26256       SUBROUTINE DT_DALTRA(GA,BGX,BGY,BGZ,PCX,PCY,PCZ,EC,P,PX,PY,PZ,E)
26257
26258 ************************************************************************
26259 * Arbitrary Lorentz-transformation.                                    *
26260 * Adopted from the original by S. Roesler. This version dated 15.01.95 *
26261 ************************************************************************
26262
26263       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26264       SAVE
26265       PARAMETER (ONE=1.0D0)
26266
26267       EP = PCX*BGX+PCY*BGY+PCZ*BGZ
26268       PE = EP/(GA+ONE)+EC
26269       PX = PCX+BGX*PE
26270       PY = PCY+BGY*PE
26271       PZ = PCZ+BGZ*PE
26272       P  = SQRT(PX*PX+PY*PY+PZ*PZ)
26273       E  = GA*EC+EP
26274
26275       RETURN
26276       END
26277
26278 *$ CREATE DT_DTRAFO.FOR
26279 *COPY DT_DTRAFO
26280 *
26281 *====dtrafo============================================================*
26282 *
26283       SUBROUTINE DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD,COF,SIF,P,ECM,
26284      &                                    PL,CXL,CYL,CZL,EL)
26285
26286 C     LORENTZ TRANSFORMATION INTO THE LAB - SYSTEM
26287
26288       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26289       SAVE
26290
26291       IF (ABS(COD).GT.1.0D0) COD = SIGN(1.0D0,COD)
26292       SID  = SQRT(1.D0-COD*COD)
26293       PLX  = P*SID*COF
26294       PLY  = P*SID*SIF
26295       PCMZ = P*COD
26296       PLZ  = GAM*PCMZ+BGAM*ECM
26297       PL   = SQRT(PLX*PLX+PLY*PLY+PLZ*PLZ)
26298       EL   = GAM*ECM+BGAM*PCMZ
26299 C     ROTATION INTO THE ORIGINAL DIRECTION
26300       COZ  = PLZ/PL
26301       SIZ  = SQRT(1.D0-COZ**2)
26302       CALL DT_STTRAN(CX,CY,CZ,COZ,SIZ,SIF,COF,CXL,CYL,CZL)
26303
26304       RETURN
26305       END
26306
26307 *$ CREATE DT_STTRAN.FOR
26308 *COPY DT_STTRAN
26309 *
26310 *====sttran============================================================*
26311 *
26312       SUBROUTINE DT_STTRAN(XO,YO,ZO,CDE,SDE,SFE,CFE,X,Y,Z)
26313
26314       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26315       SAVE
26316       DATA ANGLSQ/1.D-30/
26317 ************************************************************************
26318 *     VERSION BY                     J. RANFT                          *
26319 *                                    LEIPZIG                           *
26320 *                                                                      *
26321 *     THIS IS A SUBROUTINE OF FLUKA TO GIVE NEW DIRECTION COSINES      *
26322 *                                                                      *
26323 *     INPUT VARIABLES:                                                 *
26324 *        XO,YO,ZO = ORIGINAL DIRECTION COSINES                         *
26325 *        CDE,SDE  = COSINE AND SINE OF THE POLAR (THETA)               *
26326 *                   ANGLE OF "SCATTERING"                              *
26327 *        SDE      = SINE OF THE POLAR (THETA) ANGLE OF "SCATTERING"    *
26328 *        SFE,CFE  = SINE AND COSINE OF THE AZIMUTHAL (PHI) ANGLE       *
26329 *                   OF "SCATTERING"                                    *
26330 *                                                                      *
26331 *     OUTPUT VARIABLES:                                                *
26332 *        X,Y,Z     = NEW DIRECTION COSINES                             *
26333 *                                                                      *
26334 *     ROTATION OF COORDINATE SYSTEM (SEE CERN 64-47 )                  *
26335 ************************************************************************
26336 *
26337 *
26338 *  Changed by A. Ferrari
26339 *
26340 *     IF (ABS(XO)-0.0001D0) 1,1,2
26341 *   1 IF (ABS(YO)-0.0001D0) 3,3,2
26342 *   3 CONTINUE
26343       A = XO**2 + YO**2
26344       IF ( A .LT. ANGLSQ ) THEN
26345          X=SDE*CFE
26346          Y=SDE*SFE
26347          Z=CDE*ZO
26348       ELSE
26349          XI=SDE*CFE
26350          YI=SDE*SFE
26351          ZI=CDE
26352          A=SQRT(A)
26353          X=-YO*XI/A-ZO*XO*YI/A+XO*ZI
26354          Y=XO*XI/A-ZO*YO*YI/A+YO*ZI
26355          Z=A*YI+ZO*ZI
26356       ENDIF
26357
26358       RETURN
26359       END
26360
26361 *$ CREATE DT_MYTRAN.FOR
26362 *COPY DT_MYTRAN
26363 *
26364 *===mytran=============================================================*
26365 *
26366       SUBROUTINE DT_MYTRAN(IMODE,XO,YO,ZO,CDE,SDE,CFE,SFE,X,Y,Z)
26367
26368 ************************************************************************
26369 * This subroutine rotates the coordinate frame                         *
26370 *    a) theta  around y                                                *
26371 *    b) phi    around z      if IMODE = 1                              *
26372 *                                                                      *
26373 *     x'          cos(ph) -sin(ph) 0      cos(th)  0  sin(th)   x      *
26374 *     y' = A B =  sin(ph) cos(ph)  0  .   0        1        0   y      *
26375 *     z'          0       0        1     -sin(th)  0  cos(th)   z      *
26376 *                                                                      *
26377 * and vice versa if IMODE = 0.                                         *
26378 * This version dated 5.4.94 is based on the original version DTRAN     *
26379 * by J. Ranft and is written by S. Roesler.                            *
26380 ************************************************************************
26381
26382       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26383       SAVE
26384
26385       PARAMETER ( LINP = 10 ,
26386      &            LOUT = 6 ,
26387      &            LDAT = 9 )
26388
26389       IF (IMODE.EQ.1) THEN
26390          X= CDE*CFE*XO-SFE*YO+SDE*CFE*ZO
26391          Y= CDE*SFE*XO+CFE*YO+SDE*SFE*ZO
26392          Z=-SDE    *XO       +CDE    *ZO
26393       ELSE
26394          X= CDE*CFE*XO+CDE*SFE*YO-SDE*ZO
26395          Y= -SFE*XO+CFE*YO
26396          Z= SDE*CFE*XO+SDE*SFE*YO+CDE*ZO
26397       ENDIF
26398       RETURN
26399       END
26400
26401 *$ CREATE DT_LT2LAO.FOR
26402 *COPY DT_LT2LAO
26403 *
26404 *===lt2lab=============================================================*
26405 *
26406       SUBROUTINE DT_LT2LAO
26407
26408 ************************************************************************
26409 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26410 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26411 * and transforms them back to the lab.                                 *
26412 * This version dated 16.11.95 is written by S. Roesler                 *
26413 ************************************************************************
26414
26415       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26416       SAVE
26417
26418       PARAMETER ( LINP = 10 ,
26419      &            LOUT = 6 ,
26420      &            LDAT = 9 )
26421
26422 * event history
26423
26424       PARAMETER (NMXHKK=200000)
26425
26426       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26427      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26428      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26429
26430 * extended event history
26431       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26432      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26433      &                IHIST(2,NMXHKK)
26434
26435       NEND      = NHKK
26436       NPOINT(5) = NHKK+1
26437       IF ( (NPOINT(4).EQ.0).OR.(NEND.LT.NPOINT(4)) ) RETURN
26438       DO 1 I=NPOINT(4),NEND
26439 C     DO 1 I=1,NEND
26440          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26441      &                                (ISTHKK(I).EQ.1001)) THEN
26442             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26443             NOB = NOBAM(I)
26444             CALL DT_EVTPUT(ISTHKK(I),IDHKK(I),I,0,PHKK(1,I),PHKK(2,I),
26445      &                            PZ,PE,IDRES(I),IDXRES(I),IDCH(I))
26446             IF ((ISTHKK(I).EQ.1000).OR.(ISTHKK(I).EQ.1001)) THEN
26447                ISTHKK(I) = 3*ISTHKK(I)
26448                NOBAM(NHKK)  = NOB
26449             ELSE
26450                IF (ISTHKK(I).EQ.-1) NOBAM(NHKK)  = NOB
26451                ISTHKK(I) = SIGN(3,ISTHKK(I))
26452             ENDIF
26453             JDAHKK(1,I) = NHKK
26454          ENDIF
26455     1 CONTINUE
26456
26457       RETURN
26458       END
26459
26460 *$ CREATE DT_LT2LAB.FOR
26461 *COPY DT_LT2LAB
26462 *
26463 *===lt2lab=============================================================*
26464 *
26465       SUBROUTINE DT_LT2LAB
26466
26467 ************************************************************************
26468 * Lorentz-transformation to lab-system. This subroutine scans DTEVT1   *
26469 * for final state particles/fragments defined in nucleon-nucleon-cms   *
26470 * and transforms them to the lab.                                      *
26471 * This version dated 07.01.96 is written by S. Roesler                 *
26472 ************************************************************************
26473
26474       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26475       SAVE
26476
26477       PARAMETER ( LINP = 10 ,
26478      &            LOUT = 6 ,
26479      &            LDAT = 9 )
26480
26481 * event history
26482
26483       PARAMETER (NMXHKK=200000)
26484
26485       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
26486      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
26487      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
26488
26489 * extended event history
26490       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
26491      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
26492      &                IHIST(2,NMXHKK)
26493
26494       IF ( (NPOINT(4).EQ.0).OR.(NHKK.LT.NPOINT(4)) ) RETURN
26495       DO 1 I=NPOINT(4),NHKK
26496          IF ((ABS(ISTHKK(I)).EQ.1).OR.(ISTHKK(I).EQ.1000).OR.
26497      &                                (ISTHKK(I).EQ.1001)) THEN
26498             CALL DT_LTNUC(PHKK(3,I),PHKK(4,I),PZ,PE,-3)
26499             PHKK(3,I) = PZ
26500             PHKK(4,I) = PE
26501          ENDIF
26502     1 CONTINUE
26503
26504       RETURN
26505       END
26506
26507 ************************************************************************
26508 *                                                                      *
26509 *                 5) Sampling from distributions                       *
26510 *                                                                      *
26511 ************************************************************************
26512 *$ CREATE IDT_NPOISS.FOR
26513 *COPY IDT_NPOISS
26514 *
26515 *===npoiss=============================================================*
26516 *
26517       INTEGER FUNCTION IDT_NPOISS(AVN)
26518
26519 ************************************************************************
26520 * Sample according to Poisson distribution with Poisson parameter AVN. *
26521 * The original version written by J. Ranft.                            *
26522 * This version dated 11.1.95 is written by S. Roesler.                 *
26523 ************************************************************************
26524
26525       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26526       SAVE
26527
26528       PARAMETER ( LINP = 10 ,
26529      &            LOUT = 6 ,
26530      &            LDAT = 9 )
26531
26532       EXPAVN = EXP(-AVN)
26533       K = 1
26534       A = 1.0D0
26535
26536    10 CONTINUE
26537       A = DT_RNDM(A)*A
26538       IF (A.GE.EXPAVN) THEN
26539          K = K+1
26540          GOTO 10
26541       ENDIF
26542       IDT_NPOISS = K-1
26543
26544       RETURN
26545       END
26546
26547 *$ CREATE DT_SAMPXB.FOR
26548 *COPY DT_SAMPXB
26549 *
26550 *===sampxb=============================================================*
26551 *
26552       DOUBLE PRECISION FUNCTION DT_SAMPXB(X1,X2,B)
26553
26554 ************************************************************************
26555 * Sampling from f(x)=1./SQRT(X**2+B**2) between x1 and x2.             *
26556 * Processed by S. Roesler, 6.5.95                                      *
26557 ************************************************************************
26558
26559       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26560       SAVE
26561       PARAMETER (TWO=2.0D0)
26562
26563       A1 = LOG(X1+SQRT(X1**2+B**2))
26564       A2 = LOG(X2+SQRT(X2**2+B**2))
26565       AN = A2-A1
26566       A  = AN*DT_RNDM(A1)+A1
26567       BB = EXP(A)
26568       DT_SAMPXB = (BB**2-B**2)/(TWO*BB)
26569
26570       RETURN
26571       END
26572
26573 *$ CREATE DT_SAMPEX.FOR
26574 *COPY DT_SAMPEX
26575 *
26576 *===sampex=============================================================*
26577 *
26578       DOUBLE PRECISION FUNCTION DT_SAMPEX(X1,X2)
26579
26580 ************************************************************************
26581 * Sampling from f(x)=1./x between x1 and x2.                           *
26582 * Processed by S. Roesler, 6.5.95                                      *
26583 ************************************************************************
26584
26585       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26586       SAVE
26587       PARAMETER (ONE=1.0D0)
26588
26589       R   = DT_RNDM(X1)
26590       AL1 = LOG(X1)
26591       AL2 = LOG(X2)
26592       DT_SAMPEX = EXP((ONE-R)*AL1+R*AL2)
26593
26594       RETURN
26595       END
26596
26597 *$ CREATE DT_SAMSQX.FOR
26598 *COPY DT_SAMSQX
26599 *
26600 *===samsqx=============================================================*
26601 *
26602       DOUBLE PRECISION FUNCTION DT_SAMSQX(X1,X2)
26603
26604 ************************************************************************
26605 * Sampling from f(x)=1./x^0.5 between x1 and x2.                       *
26606 * Processed by S. Roesler, 6.5.95                                      *
26607 ************************************************************************
26608
26609       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26610       SAVE
26611       PARAMETER (ONE=1.0D0)
26612
26613       R = DT_RNDM(X1)
26614       DT_SAMSQX = (R*SQRT(X2)+(ONE-R)*SQRT(X1))**2
26615
26616       RETURN
26617       END
26618
26619 *$ CREATE DT_SAMPLW.FOR
26620 *COPY DT_SAMPLW
26621 *
26622 *===samplw=============================================================*
26623 *
26624       DOUBLE PRECISION FUNCTION DT_SAMPLW(XMIN,XMAX,B)
26625
26626 ************************************************************************
26627 * Sampling from f(x)=1/x^b between x_min and x_max.                    *
26628 * S. Roesler, 18.4.98                                                  *
26629 ************************************************************************
26630
26631       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26632       SAVE
26633       PARAMETER (ONE=1.0D0)
26634
26635       R = DT_RNDM(B)
26636       IF (B.EQ.ONE) THEN
26637          DT_SAMPLW = EXP(R*LOG(XMAX)+(ONE-R)*LOG(XMIN))
26638       ELSE
26639          ONEMB  = ONE-B
26640          DT_SAMPLW = (R*XMAX**ONEMB+(ONE-R)*XMIN**ONEMB)**(ONE/ONEMB)
26641       ENDIF
26642
26643       RETURN
26644       END
26645
26646 *$ CREATE DT_BETREJ.FOR
26647 *COPY DT_BETREJ
26648 *
26649 *===betrej=============================================================*
26650 *
26651       DOUBLE PRECISION FUNCTION DT_BETREJ(GAM,ETA,XMIN,XMAX)
26652
26653       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26654       SAVE
26655
26656       PARAMETER ( LINP = 10 ,
26657      &            LOUT = 6 ,
26658      &            LDAT = 9 )
26659
26660       PARAMETER (ONE=1.0D0)
26661
26662       IF (XMIN.GE.XMAX)THEN
26663          WRITE (LOUT,500) XMIN,XMAX
26664   500    FORMAT(1X,'DT_BETREJ:  XMIN<XMAX execution stopped ',2F10.5)
26665          STOP
26666       ENDIF
26667
26668    10 CONTINUE
26669       XX     = XMIN+(XMAX-XMIN)*DT_RNDM(ETA)
26670       BETMAX = XMIN**(GAM-ONE)*(ONE-XMIN)**(ETA-ONE)
26671       YY     = BETMAX*DT_RNDM(XX)
26672       BETXX  = XX**(GAM-ONE)*(ONE-XX)**(ETA-ONE)
26673       IF (YY.GT.BETXX) GOTO 10
26674       DT_BETREJ = XX
26675
26676       RETURN
26677       END
26678
26679 *$ CREATE DT_DGAMRN.FOR
26680 *COPY DT_DGAMRN
26681 *
26682 *===dgamrn=============================================================*
26683 *
26684       DOUBLE PRECISION FUNCTION DT_DGAMRN(ALAM,ETA)
26685
26686 ************************************************************************
26687 * Sampling from Gamma-distribution.                                    *
26688 *       F(X) = ALAM**ETA*X**(ETA-1)*EXP(-ALAM*X) / GAM(ETA)            *
26689 * Processed by S. Roesler, 6.5.95                                      *
26690 ************************************************************************
26691
26692       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26693       SAVE
26694       PARAMETER (ZERO=0.0D0,TINY9=1.0D-9,ONE=1.0D0)
26695
26696       NCOU = 0
26697       N    = INT(ETA)
26698       F    = ETA-DBLE(N)
26699       IF (F.EQ.ZERO) GOTO 20
26700    10 R = DT_RNDM(F)
26701       NCOU = NCOU+1
26702       IF (NCOU.GE.11) GOTO 20
26703       IF (R.LT.F/(F+2.71828D0)) GOTO 30
26704       YYY = LOG(DT_RNDM(R)+TINY9)/F
26705       IF (ABS(YYY).GT.50.0D0) GOTO 20
26706       Y = EXP(YYY)
26707       IF (LOG(DT_RNDM(Y)+TINY9).GT.-Y) GOTO 10
26708       GOTO 40
26709    20 Y = 0.0D0
26710       GOTO 50
26711    30 Y = ONE-LOG(DT_RNDM(Y)+TINY9)
26712       IF (DT_RNDM(R).GT.Y**(F-ONE)) GOTO 10
26713    40 IF (N.EQ.0) GOTO 70
26714    50 Z = 1.0D0
26715       DO 60 I = 1,N
26716    60 Z = Z*DT_RNDM(Z)
26717       Y = Y-LOG(Z+TINY9)
26718    70 DT_DGAMRN = Y/ALAM
26719
26720       RETURN
26721       END
26722
26723 *$ CREATE DT_DBETAR.FOR
26724 *COPY DT_DBETAR
26725 *
26726 *===dbetar=============================================================*
26727 *
26728       DOUBLE PRECISION FUNCTION DT_DBETAR(GAM,ETA)
26729
26730 ************************************************************************
26731 * Sampling from Beta -distribution between 0.0 and 1.0                 *
26732 *  F(X)=X**(GAM-1.)*(1.-X)**(ETA-1)*GAMM(ETA+GAM)/(GAMM(GAM)*GAMM(ETA))*
26733 * Processed by S. Roesler, 6.5.95                                      *
26734 ************************************************************************
26735
26736       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26737       SAVE
26738
26739       Y = DT_DGAMRN(1.0D0,GAM)
26740       Z = DT_DGAMRN(1.0D0,ETA)
26741       DT_DBETAR = Y/(Y+Z)
26742
26743       RETURN
26744       END
26745
26746 *$ CREATE DT_RANNOR.FOR
26747 *COPY DT_RANNOR
26748 *
26749 *===rannor=============================================================*
26750 *
26751       SUBROUTINE DT_RANNOR(X,Y)
26752
26753 ************************************************************************
26754 * Sampling from Gaussian distribution.                                 *
26755 * Processed by S. Roesler, 6.5.95                                      *
26756 ************************************************************************
26757
26758       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26759       SAVE
26760       PARAMETER (TINY10=1.0D-10)
26761
26762       CALL DT_DSFECF(SFE,CFE)
26763       V = MAX(TINY10,DT_RNDM(X))
26764       A = SQRT(-2.D0*LOG(V))
26765       X = A*SFE
26766       Y = A*CFE
26767
26768       RETURN
26769       END
26770
26771 *$ CREATE DT_DPOLI.FOR
26772 *COPY DT_DPOLI
26773 *
26774 *===dpoli==============================================================*
26775 *
26776       SUBROUTINE DT_DPOLI(CS,SI)
26777
26778       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26779       SAVE
26780
26781       U  = DT_RNDM(CS)
26782       CS = DT_RNDM(U)
26783       IF (U.LT.0.5D0) CS=-CS
26784       SI = SQRT(1.0D0-CS*CS+1.0D-10)
26785
26786       RETURN
26787       END
26788
26789 *$ CREATE DT_DSFECF.FOR
26790 *COPY DT_DSFECF
26791 *
26792 *===dsfecf=============================================================*
26793 *
26794       SUBROUTINE DT_DSFECF(SFE,CFE)
26795
26796       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26797       SAVE
26798       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26799
26800     1 CONTINUE
26801       X  = DT_RNDM(SFE)
26802       Y  = DT_RNDM(X)
26803       XX = X*X
26804       YY = Y*Y
26805       XY = XX+YY
26806       IF (XY.GT.ONE) GOTO 1
26807       CFE = (XX-YY)/XY
26808       SFE = TWO*X*Y/XY
26809       IF (DT_RNDM(X).LT.OHALF) SFE = -SFE
26810       RETURN
26811       END
26812
26813 *$ CREATE DT_RACO.FOR
26814 *COPY DT_RACO
26815 *
26816 *===raco===============================================================*
26817 *
26818       SUBROUTINE DT_RACO(WX,WY,WZ)
26819
26820 ************************************************************************
26821 * Direction cosines of random uniform (isotropic) direction in three   *
26822 * dimensional space                                                    *
26823 * Processed by S. Roesler, 20.11.95                                    *
26824 ************************************************************************
26825
26826       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26827       SAVE
26828       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0)
26829
26830   10  CONTINUE
26831       X  = TWO*DT_RNDM(WX)-ONE
26832       Y  = DT_RNDM(X)
26833       X2 = X*X
26834       Y2 = Y*Y
26835       IF (X2+Y2.GT.ONE) GOTO 10
26836
26837       CFE = (X2-Y2)/(X2+Y2)
26838       SFE = TWO*X*Y/(X2+Y2)
26839 * z = 1/2 [ 1 + cos (theta) ]
26840       Z   = DT_RNDM(X)
26841 * 1/2 sin (theta)
26842       WZ = SQRT(Z*(ONE-Z))
26843       WX = TWO*WZ*CFE
26844       WY = TWO*WZ*SFE
26845       WZ = TWO*Z-ONE
26846
26847       RETURN
26848       END
26849
26850 ************************************************************************
26851 *                                                                      *
26852 *           6) Special functions, algorithms and service routines      *
26853 *                                                                      *
26854 ************************************************************************
26855 *$ CREATE DT_YLAMB.FOR
26856 *COPY DT_YLAMB
26857 *
26858 *===ylamb==============================================================*
26859 *
26860       DOUBLE PRECISION FUNCTION DT_YLAMB(X,Y,Z)
26861
26862 ************************************************************************
26863 *                                                                      *
26864 *     auxiliary function for three particle decay mode                 *
26865 *     (standard LAMBDA**(1/2) function)                                *
26866 *                                                                      *
26867 * Adopted from an original version written by R. Engel.                *
26868 * This version dated 12.12.94 is written by S. Roesler.                *
26869 ************************************************************************
26870
26871       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26872       SAVE
26873
26874       YZ   = Y-Z
26875       XLAM = X*X-2.D0*X*(Y+Z)+YZ*YZ
26876       IF (XLAM.LE.0.D0) XLAM = ABS(XLAM)
26877       DT_YLAMB = SQRT(XLAM)
26878
26879       RETURN
26880       END
26881
26882 *$ CREATE DT_SORT.FOR
26883 *COPY DT_SORT
26884 *
26885 *===sort1==============================================================*
26886 *
26887       SUBROUTINE DT_SORT(A,N,I0,I1,MODE)
26888
26889 ************************************************************************
26890 * This subroutine sorts entries in A in increasing/decreasing order    *
26891 * of A(3,i).                                                           *
26892 *              MODE  = 1     increasing in A(3,i=1..N)                 *
26893 *                    = 2     decreasing in A(3,i=1..N)                 *
26894 * This version dated 21.04.95 is revised by S. Roesler                 *
26895 ************************************************************************
26896
26897       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26898       SAVE
26899
26900       DIMENSION A(3,N)
26901
26902       M = I1
26903    10 CONTINUE
26904       M = I1-1
26905       IF (M.LE.0) RETURN
26906       L = 0
26907       DO 20 I=I0,M
26908          J = I+1
26909          IF (MODE.EQ.1) THEN
26910             IF (A(3,I).LE.A(3,J)) GOTO 20
26911          ELSE
26912             IF (A(3,I).GE.A(3,J)) GOTO 20
26913          ENDIF
26914          B = A(3,I)
26915          C = A(1,I)
26916          D = A(2,I)
26917          A(3,I) = A(3,J)
26918          A(2,I) = A(2,J)
26919          A(1,I) = A(1,J)
26920          A(3,J) = B
26921          A(1,J) = C
26922          A(2,J) = D
26923          L = 1
26924    20 CONTINUE
26925       IF (L.EQ.1) GOTO 10
26926
26927       RETURN
26928       END
26929
26930 *$ CREATE DT_SORT1.FOR
26931 *COPY DT_SORT1
26932 *
26933 *===sort1==============================================================*
26934 *
26935       SUBROUTINE DT_SORT1(A,IDX,N,I0,I1,MODE)
26936
26937 ************************************************************************
26938 * This subroutine sorts entries in A in increasing/decreasing order    *
26939 * of A(i).                                                             *
26940 *              MODE  = 1     increasing in A(i=1..N)                   *
26941 *                    = 2     decreasing in A(i=1..N)                   *
26942 * This version dated 21.04.95 is revised by S. Roesler                 *
26943 ************************************************************************
26944
26945       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26946       SAVE
26947
26948       DIMENSION A(N),IDX(N)
26949
26950       M = I1
26951    10 CONTINUE
26952       M = I1-1
26953       IF (M.LE.0) RETURN
26954       L = 0
26955       DO 20 I=I0,M
26956          J = I+1
26957          IF (MODE.EQ.1) THEN
26958             IF (A(I).LE.A(J)) GOTO 20
26959          ELSE
26960             IF (A(I).GE.A(J)) GOTO 20
26961          ENDIF
26962          B    = A(I)
26963          A(I) = A(J)
26964          A(J) = B
26965          IX     = IDX(I)
26966          IDX(I) = IDX(J)
26967          IDX(J) = IX
26968          L = 1
26969    20 CONTINUE
26970       IF (L.EQ.1) GOTO 10
26971
26972       RETURN
26973       END
26974
26975 *$ CREATE DT_XTIME.FOR
26976 *COPY DT_XTIME
26977 *
26978 *===xtime==============================================================*
26979 *
26980       SUBROUTINE DT_XTIME
26981
26982       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
26983       SAVE
26984
26985       PARAMETER ( LINP = 10 ,
26986      &            LOUT = 6 ,
26987      &            LDAT = 9 )
26988
26989       CHARACTER DAT*9,TIM*11
26990
26991       DAT = '         '
26992       TIM = '           '
26993 C     CALL GETDAT(IYEAR,IMONTH,IDAY)
26994 C     CALL GETTIM(IHOUR,IMINUT,ISECND,IHSCND)
26995
26996 C     CALL DATE(DAT)
26997 C     CALL TIME(TIM)
26998 C     WRITE(LOUT,1000) DAT,TIM
26999  1000 FORMAT(/,2X,'Date: ',A9,3X,'Time: ',A11,/)
27000
27001       RETURN
27002       END
27003
27004 ************************************************************************
27005 *                                                                      *
27006 *                 7) Random number generator package                   *
27007 *                                                                      *
27008 *    THIS IS A PACKAGE CONTAINING A RANDOM NUMBER GENERATOR AND        *
27009 *    SERVICE ROUTINES.                                                 *
27010 *    THE ALGORITHM IS FROM                                             *
27011 *      'TOWARD A UNVERSAL RANDOM NUMBER GENERATOR'                     *
27012 *      G.MARSAGLIA, A.ZAMAN ;  FSU-SCRI-87-50                          *
27013 *    IMPLEMENTATION BY K. HAHN  DEC. 88,                               *
27014 *    THIS GENERATOR SHOULD NOT DEPEND ON THE HARD WARE ( IF A REAL HAS *
27015 *    AT LEAST 24 SIGNIFICANT BITS IN INTERNAL REPRESENTATION ),        *
27016 *    THE PERIOD IS ABOUT 2**144,                                       *
27017 *    TIME FOR ONE CALL AT IBM-XT IS ABOUT 0.7 MILLISECONDS,            *
27018 *    THE PACKAGE CONTAINS                                              *
27019 *      FUNCTION DT_RNDM(I)                  : GENERATOR                *
27020 *      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB4): INITIALIZATION           *
27021 *      SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)  : PUT SEED TO GENERATOR    *
27022 *      SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)  : TAKE SEED FROM GENERATOR *
27023 *      SUBROUTINE DT_RNDMTE(IO)             : TEST OF GENERATOR        *
27024 *---                                                                   *
27025 *    FUNCTION DT_RNDM(I)                                               *
27026 *       GIVES UNIFORMLY DISTRIBUTED RANDOM NUMBERS  IN (0..1)          *
27027 *       I  - DUMMY VARIABLE, NOT USED                                  *
27028 *    SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)                             *
27029 *       INITIALIZES THE GENERATOR, MUST BE CALLED BEFORE USING DT_RNDM *
27030 *       NA1,NA2,NA3,NB1  - VALUES FOR INITIALIZING THE GENERATOR       *
27031 *                          NA? MUST BE IN 1..178 AND NOT ALL 1         *
27032 *                          12,34,56  ARE THE STANDARD VALUES           *
27033 *                          NB1 MUST BE IN 1..168                       *
27034 *                          78  IS THE STANDARD VALUE                   *
27035 *    SUBROUTINE DT_RNDMIN(U,C,CD,CM,I,J)                               *
27036 *       PUTS SEED TO GENERATOR ( BRINGS GENERATOR IN THE SAME STATUS   *
27037 *       AS AFTER THE LAST DT_RNDMOU CALL )                             *
27038 *       U(97),C,CD,CM,I,J  - SEED VALUES AS TAKEN FROM DT_RNDMOU       *
27039 *    SUBROUTINE DT_RNDMOU(U,C,CD,CM,I,J)                               *
27040 *       TAKES SEED FROM GENERATOR                                      *
27041 *       U(97),C,CD,CM,I,J  - SEED VALUES                               *
27042 *    SUBROUTINE DT_RNDMTE(IO)                                          *
27043 *       TEST OF THE GENERATOR                                          *
27044 *       IO     - DEFINES OUTPUT                                        *
27045 *                  = 0  OUTPUT ONLY IF AN ERROR IS DETECTED            *
27046 *                  = 1  OUTPUT INDEPENDEND ON AN ERROR                 *
27047 *       DT_RNDMTE USES DT_RNDMIN AND DT_RNDMOU TO BRING GENERATOR TO   *
27048 *       SAME STATUS                                                    *
27049 *       AS BEFORE CALL OF DT_RNDMTE                                    *
27050 ************************************************************************
27051 *$ CREATE DT_RNDM.FOR
27052 *COPY DT_RNDM
27053 *
27054 *===rndm===============================================================*
27055 *
27056 c$$$      DOUBLE PRECISION FUNCTION DT_RNDM(VDUMMY)
27057 c$$$
27058 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27059 c$$$      SAVE
27060 c$$$
27061 c$$$* counter of calls to random number generator
27062 c$$$* uncomment if needed
27063 c$$$C     COMMON /DTRNCT/ IRNCT0,IRNCT1
27064 c$$$C     LOGICAL LFIRST
27065 c$$$C     DATA LFIRST /.TRUE./
27066 c$$$
27067 c$$$* counter of calls to random number generator
27068 c$$$* uncomment if needed
27069 c$$$C     IF (LFIRST) THEN
27070 c$$$C        IRNCT0 = 0
27071 c$$$C        IRNCT1 = 0
27072 c$$$C        LFIRST = .FALSE.
27073 c$$$C     ENDIF
27074 c$$$
27075 c$$$      DT_RNDM = FLRNDM(VDUMMY)
27076 c$$$* counter of calls to random number generator
27077 c$$$* uncomment if needed
27078 c$$$C     IRNCT1 = IRNCT1+1
27079 c$$$
27080 c$$$      RETURN
27081 c$$$      END
27082 c$$$
27083 c$$$*$ CREATE DT_RNDMST.FOR
27084 c$$$*COPY DT_RNDMST
27085 c$$$*
27086 c$$$*===rndmst=============================================================*
27087 c$$$*
27088 c$$$      SUBROUTINE DT_RNDMST(NA1,NA2,NA3,NB1)
27089 c$$$
27090 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27091 c$$$      SAVE
27092 c$$$
27093 c$$$* random number generator
27094 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27095 c$$$
27096 c$$$      MA1 = NA1
27097 c$$$      MA2 = NA2
27098 c$$$      MA3 = NA3
27099 c$$$      MB1 = NB1
27100 c$$$      I   = 97
27101 c$$$      J   = 33
27102 c$$$      DO 20 II2 = 1,97
27103 c$$$        S = 0
27104 c$$$        T = 0.5D0
27105 c$$$        DO 10 II1 = 1,24
27106 c$$$          MAT  = MOD(MOD(MA1*MA2,179)*MA3,179)
27107 c$$$          MA1  = MA2
27108 c$$$          MA2  = MA3
27109 c$$$          MA3  = MAT
27110 c$$$          MB1  = MOD(53*MB1+1,169)
27111 c$$$          IF ( MOD(MB1*MAT,64).GE.32 ) S = S+T
27112 c$$$   10   T = 0.5D0*T
27113 c$$$   20 U(II2) = S
27114 c$$$      C  =   362436.0D0/16777216.0D0
27115 c$$$      CD =  7654321.0D0/16777216.0D0
27116 c$$$      CM = 16777213.0D0/16777216.0D0
27117 c$$$      RETURN
27118 c$$$      END
27119 c$$$
27120 c$$$*$ CREATE DT_RNDMIN.FOR
27121 c$$$*COPY DT_RNDMIN
27122 c$$$*
27123 c$$$*===rndmin=============================================================*
27124 c$$$*
27125 c$$$      SUBROUTINE DT_RNDMIN(UIN,CIN,CDIN,CMIN,IIN,JIN)
27126 c$$$
27127 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27128 c$$$      SAVE
27129 c$$$
27130 c$$$* random number generator
27131 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27132 c$$$
27133 c$$$      DIMENSION UIN(97)
27134 c$$$
27135 c$$$      DO 10 KKK = 1,97
27136 c$$$   10 U(KKK) = UIN(KKK)
27137 c$$$      C  = CIN
27138 c$$$      CD = CDIN
27139 c$$$      CM = CMIN
27140 c$$$      I  = IIN
27141 c$$$      J  = JIN
27142 c$$$
27143 c$$$      RETURN
27144 c$$$      END
27145 c$$$
27146 c$$$*$ CREATE DT_RNDMOU.FOR
27147 c$$$*COPY DT_RNDMOU
27148 c$$$*
27149 c$$$*===rndmou=============================================================*
27150 c$$$*
27151 c$$$      SUBROUTINE DT_RNDMOU(UOUT,COUT,CDOUT,CMOUT,IOUT,JOUT)
27152 c$$$
27153 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27154 c$$$      SAVE
27155 c$$$
27156 c$$$* random number generator
27157 c$$$      COMMON /DTRAND/ U(97),C,CD,CM,I,J
27158 c$$$
27159 c$$$      DIMENSION UOUT(97)
27160 c$$$
27161 c$$$      DO 10 KKK = 1,97
27162 c$$$   10 UOUT(KKK) = U(KKK)
27163 c$$$      COUT  = C
27164 c$$$      CDOUT = CD
27165 c$$$      CMOUT = CM
27166 c$$$      IOUT  = I
27167 c$$$      JOUT  = J
27168 c$$$
27169 c$$$      RETURN
27170 c$$$      END
27171 c$$$
27172 c$$$*$ CREATE DT_RNDMTE.FOR
27173 c$$$*COPY DT_RNDMTE
27174 c$$$*
27175 c$$$*===rndmte=============================================================*
27176 c$$$*
27177 c$$$      SUBROUTINE DT_RNDMTE(IO)
27178 c$$$
27179 c$$$      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27180 c$$$      SAVE
27181 c$$$
27182 c$$$      DIMENSION UU(97),U(6),X(6),D(6)
27183 c$$$      DATA U / 6533892.D0, 14220222.D0, 7275067.D0, 6172232.D0,
27184 c$$$     +8354498.D0, 10633180.D0/
27185 c$$$
27186 c$$$      CALL DT_RNDMOU(UU,CC,CCD,CCM,II,JJ)
27187 c$$$      CALL DT_RNDMST(12,34,56,78)
27188 c$$$      DO 10 II1 = 1,20000
27189 c$$$   10 XX = DT_RNDM(XX)
27190 c$$$      SD        = 0.0D0
27191 c$$$      DO 20 II2 = 1,6
27192 c$$$        X(II2)  = 4096.D0*(4096.D0*DT_RNDM(SD))
27193 c$$$        D(II2)  = X(II2)-U(II2)
27194 c$$$   20 SD = SD+D(II2)
27195 c$$$      CALL DT_RNDMIN(UU,CC,CCD,CCM,II,JJ)
27196 c$$$**sr 24.01.95
27197 c$$$C     IF ( IO.EQ. 1.OR. SD.NE.0. 0) WRITE(6,500) (U(I),X(I),D(I),I=1,6)
27198 c$$$      IF ((IO.EQ.1).OR.(SD.NE.0.0)) THEN
27199 c$$$C        WRITE(6,1000)
27200 c$$$ 1000    FORMAT(/,/,1X,'DT_RNDMTE: Test of random-number generator...',
27201 c$$$     &          ' passed')
27202 c$$$      ENDIF
27203 c$$$**
27204 c$$$      RETURN
27205 c$$$  500 FORMAT('  === TEST OF THE RANDOM-GENERATOR ===',/,
27206 c$$$     &'    EXPECTED VALUE    CALCULATED VALUE     DIFFERENCE',/, 6(F17.
27207 c$$$     &1,F20.1,F15.3,/), '  === END OF TEST ;',
27208 c$$$     &'  GENERATOR HAS THE SAME STATUS AS BEFORE CALLING DT_RNDMTE')
27209 c$$$      END
27210 *
27211 *$ CREATE PHO_RNDM.FOR
27212 *COPY PHO_RNDM
27213 *
27214 *===pho_rndm===========================================================*
27215 *
27216       DOUBLE PRECISION FUNCTION PHO_RNDM(DUMMY)
27217
27218       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27219       SAVE
27220
27221       PHO_RNDM = DT_RNDM(DUMMY)
27222
27223       RETURN
27224       END
27225
27226 *$ CREATE PYR.FOR
27227 *COPY PYR
27228 *
27229 *===pyr================================================================*
27230 *
27231       DOUBLE PRECISION FUNCTION PYR(IDUMMY)
27232
27233       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27234       SAVE
27235
27236       DUMMY = DBLE(IDUMMY)
27237       PYR = DT_RNDM(DUMMY)
27238
27239       RETURN
27240       END
27241 *$ CREATE DT_TITLE.FOR
27242 *COPY DT_TITLE
27243 *
27244 *===title==============================================================*
27245 *
27246       SUBROUTINE DT_TITLE
27247
27248       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27249       SAVE
27250
27251       PARAMETER ( LINP = 10 ,
27252      &            LOUT = 6 ,
27253      &            LDAT = 9 )
27254
27255       CHARACTER*6 CVERSI
27256       CHARACTER*11 CCHANG
27257       DATA CVERSI,CCHANG /'3.0-5 ','31 Oct 2008'/
27258
27259       CALL DT_XTIME
27260       WRITE(LOUT,1000) CVERSI,CCHANG
27261  1000 FORMAT(1X,'+-------------------------------------------------',
27262      &                  '----------------------+',/,
27263      &     1X,'|',71X,'|',/,
27264      &     1X,'|',26X,'DPMJET version ',A6,24X,'|',/,
27265      &     1X,'|',71X,'|',/,
27266      &     1X,'|',22X,'(Last change: ',A11,')',23X,'|',/,
27267      &     1X,'|',71X,'|',/,
27268      &     1X,'|',12X,'Authors: Stefan Roesler   (CERN)',27X,'|',/,
27269      &     1X,'|',21X,'Ralph Engel      (FZ Karlsruhe)',19X,'|',/,
27270      &     1X,'|',21X,'Johannes Ranft   (Siegen Univ.)',19X,'|',/,
27271 C    &     1X,'|',71X,'|',/,
27272 C    &     1X,'|',12X,'http://home.cern.ch/~sroesler/dpmjet3.html',
27273 C    &                                              17X,'|',/,
27274      &     1X,'|',71X,'|',/,
27275      &     1X,'+-------------------------------------------------',
27276      &                '----------------------+',/,
27277      &     1X,'| Please send suggestions, bug reports, etc. to: ',
27278      &                                  'Stefan.Roesler@cern.ch |',/,
27279      &     1X,'+-------------------------------------------------',
27280      &                '----------------------+',/)
27281
27282       RETURN
27283       END
27284
27285 *$ CREATE DT_EVTINI.FOR
27286 *COPY DT_EVTINI
27287 *
27288 *===evtini=============================================================*
27289 *
27290       SUBROUTINE DT_EVTINI
27291
27292 ************************************************************************
27293 * Initialization of DTEVT1.                                            *
27294 * This version dated 15.01.94 is written by S. Roesler                 *
27295 ************************************************************************
27296
27297       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27298       SAVE
27299
27300       PARAMETER ( LINP = 10 ,
27301      &            LOUT = 6 ,
27302      &            LDAT = 9 )
27303
27304 * event history
27305
27306       PARAMETER (NMXHKK=200000)
27307
27308       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27309      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27310      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27311
27312 * extended event history
27313       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27314      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27315      &                IHIST(2,NMXHKK)
27316
27317 * event flag
27318       COMMON /DTEVNO/ NEVENT,ICASCA
27319
27320       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
27321
27322 * emulsion treatment
27323       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
27324      &                NCOMPO,IEMUL
27325
27326 * initialization of DTEVT1/DTEVT2
27327       NEND = NHKK
27328       IF (NEVENT.EQ.1) NEND = NMXHKK
27329       NHKK   = 0
27330       NEVHKK = NEVENT
27331       DO 1 I=1,NEND
27332          ISTHKK(I)   = 0
27333          IDHKK(I)    = 0
27334          JMOHKK(1,I) = 0
27335          JMOHKK(2,I) = 0
27336          JDAHKK(1,I) = 0
27337          JDAHKK(2,I) = 0
27338          IDRES(I)    = 0
27339          IDXRES(I)   = 0
27340          NOBAM(I)    = 0
27341          IDCH(I)     = 0
27342          IHIST(1,I)  = 0
27343          IHIST(2,I)  = 0
27344          DO 2 J=1,4
27345             PHKK(J,I) = 0.0D0
27346             VHKK(J,I) = 0.0D0
27347             WHKK(J,I) = 0.0D0
27348     2    CONTINUE
27349          PHKK(5,I) = 0.0D0
27350     1 CONTINUE
27351       DO 3 I=1,10
27352          NPOINT(I) = 0
27353     3 CONTINUE
27354       CALL DT_CHASTA(-1)
27355
27356 C* initialization of DTLTRA
27357 C      IF (NCOMPO.GT.0) CALL DT_LTINI(ID,EPN,PPN,ECM)
27358
27359       RETURN
27360       END
27361
27362 *$ CREATE DT_STATIS.FOR
27363 *COPY DT_STATIS
27364 *
27365 *===statis=============================================================*
27366 *
27367       SUBROUTINE DT_STATIS(MODE)
27368
27369 ************************************************************************
27370 * Initialization and output of run-statistics.                         *
27371 *              MODE  = 1     initialization                            *
27372 *                    = 2     output                                    *
27373 * This version dated 23.01.94 is written by S. Roesler                 *
27374 ************************************************************************
27375
27376       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27377       SAVE
27378
27379       PARAMETER ( LINP = 10 ,
27380      &            LOUT = 6 ,
27381      &            LDAT = 9 )
27382
27383       PARAMETER (TINY3=1.0D-3)
27384
27385 * statistics
27386       COMMON /DTSTA1/ ICREQU,ICSAMP,ICCPRO,ICDPR,ICDTA,
27387      &                ICRJSS,ICVV2S,ICCHAI(2,9),ICRES(9),ICDIFF(5),
27388      &                ICEVTG(8,0:30)
27389
27390 * rejection counter
27391       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27392      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27393      &                IREXCI(3),IRDIFF(2),IRINC
27394
27395 * central particle production, impact parameter biasing
27396       COMMON /DTIMPA/ BIMIN,BIMAX,XSFRAC,ICENTR
27397
27398 * various options for treatment of partons (DTUNUC 1.x)
27399 * (chain recombination, Cronin,..)
27400       LOGICAL LCO2CR,LINTPT
27401       COMMON /DTCHAI/ SEASQ,CRONCO,CUTOF,MKCRON,ISICHA,IRECOM,
27402      &                LCO2CR,LINTPT
27403
27404 * nucleon-nucleon event-generator
27405       CHARACTER*8 CMODEL
27406       LOGICAL LPHOIN
27407       COMMON /DTMODL/ CMODEL(4),ELOJET,MCGENE,LPHOIN
27408
27409 * flags for particle decays
27410       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
27411      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
27412      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
27413
27414 * diquark-breaking mechanism
27415       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
27416
27417       DIMENSION PP(4),PT(4)
27418
27419       GOTO (1,2) MODE
27420
27421 * initialization
27422     1 CONTINUE
27423
27424 *   initialize statistics counter
27425       ICREQU = 0
27426       ICSAMP = 0
27427       ICCPRO = 0
27428       ICDPR  = 0
27429       ICDTA  = 0
27430       ICRJSS = 0
27431       ICVV2S = 0
27432       DO 10 I=1,9
27433          ICRES(I)    = 0
27434          ICCHAI(1,I) = 0
27435          ICCHAI(2,I) = 0
27436    10 CONTINUE
27437 *   initialize rejection counter
27438       IRPT      = 0
27439       IRHHA     = 0
27440       LOMRES    = 0
27441       LOBRES    = 0
27442       IRFRAG    = 0
27443       IREVT     = 0
27444       IRRES(1)  = 0
27445       IRRES(2)  = 0
27446       IRCHKI(1) = 0
27447       IRCHKI(2) = 0
27448       IRCRON(1) = 0
27449       IRCRON(2) = 0
27450       IRCRON(3) = 0
27451       IRDIFF(1) = 0
27452       IRDIFF(2) = 0
27453       IRINC     = 0
27454       DO 11 I=1,5
27455          ICDIFF(I) = 0
27456    11 CONTINUE
27457       DO 12 I=1,8
27458          DO 13 J=0,30
27459             ICEVTG(I,J) = 0
27460    13    CONTINUE
27461    12 CONTINUE
27462
27463       RETURN
27464
27465 * output
27466     2 CONTINUE
27467
27468 *   statistics counter
27469       WRITE(LOUT,1000)
27470  1000 FORMAT(/,/,1X,'STATIS:',20X,'statistics of the run',/,
27471      &       28X,'---------------------')
27472       IF (ICREQU.GT.0) THEN
27473       WRITE(LOUT,1001) ICREQU,ICSAMP,DBLE(ICSAMP)/DBLE(ICREQU)
27474  1001 FORMAT(/,1X,'number of events requested / sampled',13X,
27475      &       I8,' / ',I8,/,1X,'number of samp. evts per requested ',
27476      &       'event',11X,F9.1)
27477       ENDIF
27478       IF (ICDIFF(1).NE.0) THEN
27479          WRITE(LOUT,1009) ICDIFF
27480  1009    FORMAT(/,1X,'diffractive events:    total   ',I8,/,49X,
27481      &          'low mass   high mass',/,24X,'single diffraction',
27482      &          7X,I8,4X,I8,/,24X,'double diffraction',7X,I8,4X,I8)
27483       ENDIF
27484       IF (ICENTR.GT.0.AND.ICSAMP.GT.0.AND.ICCPRO.GT.0) THEN
27485          WRITE(LOUT,1002) DBLE(ICCPRO)/DBLE(ICSAMP),
27486      &                    DBLE(ICSAMP)/DBLE(ICCPRO)
27487  1002    FORMAT(/,1X,'central production:',/,2X,'mean number',
27488      &          ' of sampled Glauber-events per event',9X,F9.1,/,
27489      &          2X,'fraction of production cross section',21X,F10.6)
27490       ENDIF
27491       IF (ICSAMP.GT.0) THEN
27492       WRITE(LOUT,1003) DBLE(ICDPR)/DBLE(ICSAMP),
27493      &                 DBLE(ICDTA)/DBLE(ICSAMP)
27494  1003 FORMAT(/,54X,'proj.    targ.',/,1X,'average number of wounded',
27495      &       ' nucleons after x-sampling',2(4X,F6.2))
27496       ENDIF
27497
27498       IF (MCGENE.EQ.1) THEN
27499          IF (ICSAMP.GT.0) THEN
27500          WRITE(LOUT,1004) DBLE(ICRJSS)/DBLE(ICSAMP)
27501  1004    FORMAT(/,1X,'mean number of sea-sea chain rejections per',
27502      &          ' event',3X,F9.1)
27503          IF (ISICHA.EQ.1) THEN
27504             WRITE(LOUT,1005) DBLE(ICVV2S)/DBLE(ICSAMP)
27505  1005       FORMAT(/,1X,'Reggeon contribution:',/,1X,'mean number ',
27506      &             'of single chains  per event',13X,F9.1)
27507          ENDIF
27508          ENDIF
27509          IF (ICSAMP.GT.0.AND.ICREQU.GT.0) THEN
27510          WRITE(LOUT,1006)
27511  1006    FORMAT(/,1X,'chain system statistics:  (per event)',/,
27512      &       23X,'mean number of chains      mean number of chains',/,
27513      &       23X,'sampled    hadronized      having mass of a reso.')
27514          WRITE(LOUT,1007) (DBLE(ICCHAI(1,J))/(2.0D0*DBLE(ICSAMP)),
27515      &                     DBLE(ICCHAI(2,J))/(2.0D0*DBLE(ICREQU)),
27516      &                     DBLE(ICRES(J))/(2.0D0*DBLE(ICREQU)),J=1,8),
27517      &                  DBLE(ICCHAI(2,9))/MAX(DBLE(ICCHAI(1,9)),TINY3)
27518  1007    FORMAT(1X,'sea     - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27519      &          1X,'disea   - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27520      &          1X,'sea     - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27521      &          1X,'sea     - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27522      &          1X,'disea   - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27523      &          1X,'valence - sea     ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27524      &          1X,'valence - disea   ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27525      &          1X,'valence - valence ',6X,F4.1,8X,F4.1,17X,F4.1,/,
27526      &          1X,'fused chains      ',18X,F4.1,17X,F4.1,/)
27527          WRITE(LOUT,1008)
27528      &     (DBLE(IRCRON(I))/MAX(DBLE(IRCRON(1)),TINY3),I=2,3),
27529      &     DBLE(IRPT)/DBLE(ICREQU),(DBLE(IRRES(I))/DBLE(ICREQU),I=1,2),
27530      &     DBLE(LOMRES)/DBLE(ICREQU),DBLE(LOBRES)/DBLE(ICREQU),
27531      &     (DBLE(IRCHKI(I))/DBLE(ICREQU),I=1,2),
27532      &     (DBLE(IRDIFF(I))/DBLE(ICREQU),I=1,2),
27533      &     DBLE(IRHHA)/DBLE(ICREQU),
27534      &     DBLE(IRFRAG)/DBLE(ICREQU),DBLE(IREVT)/DBLE(ICREQU),
27535      &     (DBLE(IREXCI(I))/DBLE(ICREQU),I=1,2),IREXCI(3)
27536  1008    FORMAT(/,1X,'Rejection counter:  (NEVT = no. of events)',/,/,
27537      &       1X,'Cronin-effect (CRONIN)',15X,'IRCRON(2)/IRCRON(1) = ',
27538      &       F7.2,/,38X,'IRCRON(3)/IRCRON(1) = ',F7.2,/,1X,
27539      &       'Intrins. p_t (GETSPT)',21X,'IRPT     /NEVT = ',F7.2,/,
27540      &       1X,'Chain mass corr. for resonances (EVTRES)',2X,
27541      &       'IRRES(1) /NEVT = ',F7.2,/,33X,'(CH2RES)  IRRES(2) /',
27542      &       'NEVT = ',F7.2,/,43X,'LOMRES   /NEVT = ',F7.2,/,
27543      &       43X,'LOBRES   /NEVT = ',F7.2,/,1X,'Kinem. corr. of',
27544      &       ' 2-chain systems (CHKINE)  IRCHKI(1)/NEVT = ',F7.2,/,
27545      &       43X,'IRCHKI(2)/NEVT = ',F7.2,/,1X,'Diffraction',31X,
27546      &       'IRDIFF(1)/NEVT = ',F7.2,/,43X,'IRDIFF(2)/NEVT = ',
27547      &       F7.2,/,1X,'Total no. of rej.',
27548      &       ' in chain-systems treatment (GETCSY)',/,43X,
27549      &       'IRHHA    /NEVT = ',F7.2,/,1X,'Fragmentation (EVTFRA)',
27550      &       ' (not yet used!)',4X,'IRFRAG   /NEVT = ',F7.2,/,
27551      &       1X,'Total no. of rej. in DPM-treatment of one event',
27552      &       ' (EVENTA)',/,43X,'IREVT    /NEVT = ',F7.2,/,1X,
27553      &       'Treatment of final nucleon conf.',10X,'IREXCI(1)/NEVT = '
27554      &       ,F7.2,/,43X,'IREXCI(2)/NEVT = ',F7.2,/,48X,
27555      &       'IREXCI(3) = ',I5,/)
27556          ENDIF
27557       ELSEIF (MCGENE.EQ.2) THEN
27558          WRITE(LOUT,1010) ELOJET
27559  1010    FORMAT(/,/,1X,'PHOJET-treatment of chain systems above  ',
27560      &          F4.1,' GeV')
27561          WRITE(LOUT,1011)
27562  1011    FORMAT(/,1X,'1. chain system statistics - total numbers:',/,
27563      &          30X,'--------------',/,/,12X,'s-s',5X,'d-s',5X,'s-d',
27564      &          5X,'s-v',5X,'d-v',5X,'v-s',5X,'v-d',5X,'v-v')
27565          WRITE(LOUT,1012) ((ICEVTG(I,J),I=1,8),J=0,1),
27566      &                    (INT(ICCHAI(2,I)/2.0D0),I=1,8),
27567      &                    (ICEVTG(I,2),I=1,8),(ICEVTG(I,29),I=1,8),
27568      &                    ((ICEVTG(I,J),I=1,8),J=3,7),
27569      &                    ((ICEVTG(I,J),I=1,8),J=19,21),
27570      &                    (ICEVTG(I,8),I=1,8),
27571      &                    ((ICEVTG(I,J),I=1,8),J=22,24),
27572      &                    (ICEVTG(I,9),I=1,8),
27573      &                    ((ICEVTG(I,J),I=1,8),J=25,28),
27574      &                    ((ICEVTG(I,J),I=1,8),J=10,18)
27575  1012    FORMAT(/,1X,'req.to.',8I8,/,/,1X,'low rq.',8I8,/,1X,'low ac.',
27576      &          8I8,/,/,1X,'PHOJET ',8I8,/,'   sngl ',8I8,/,/,
27577      &          ' no-dif.',8I8,/,
27578      &          ' el-sca.',8I8,/,' qel-sc.',8I8,/,' dbl-Po.',8I8,/,
27579      &          ' diff-1 ',8I8,/,'  low   ',8I8,/,'  high  ',8I8,/,
27580      &          '  h-diff',8I8,/,' diff-2 ',8I8,/,'  low   ',8I8,/,
27581      &          '  high  ',8I8,/,'  h-diff',8I8,/,' dbl-di.',8I8,/,
27582      &          '  lo-lo ',8I8,/,'  hi-hi ',8I8,/,'  lo-hi ',8I8,/,
27583      &          '  hi-lo ',8I8,/,
27584      &          ' dir-ga.',8I8,/,/,' dir-1  ',8I8,/,' dir-2  ',8I8,/,
27585      &          ' dbl-dir',8I8,/,' s-Pom. ',8I8,/,' h-Pom. ',8I8,/,
27586      &          ' s-Reg. ',8I8,/,' enh-trg',8I8,/,' enh-log',8I8)
27587          WRITE(LOUT,1013)
27588  1013    FORMAT(/,1X,'2. chain system statistics -',
27589      &          ' mean numbers per evt:',/,30X,'---------------------',
27590      &          /,/,16X,'s-s',7X,'d-s',7X,'s-d')
27591          IF (ICSAMP.GT.0) THEN
27592          WRITE(LOUT,1014)
27593      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=0,1),
27594      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=1,3),
27595      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=1,3),J=2,18)
27596  1014    FORMAT(/,1X,'req.to.    ',3E10.2,/,/,1X,'low rq.    ',3E10.2,/,
27597      &          1X,'low ac.    ',3E10.2,/,/,1X,'PHOJET     ',3E10.2,/,/,
27598      &          ' no-dif.    ',3E10.2,/,' el-sca.    ',3E10.2,/,
27599      &          ' qel-sc.    ',3E10.2,/,' dbl-Po.    ',3E10.2,/,
27600      &          ' diff-1     ',3E10.2,/,' diff-2     ',3E10.2,/,
27601      &          ' dbl-di.    ',3E10.2,/,' dir-ga.    ',3E10.2,/,/,
27602      &          ' dir-1      ',3E10.2,/,' dir-2      ',3E10.2,/,
27603      &          ' dbl-dir    ',3E10.2,/,' s-Pom.     ',3E10.2,/,
27604      &          ' h-Pom.     ',3E10.2,/,' s-Reg.     ',3E10.2,/,
27605      &          ' enh-trg    ',3E10.2,/,' enh-log    ',3E10.2)
27606          ENDIF
27607          WRITE(LOUT,1015)
27608  1015    FORMAT(/,16X,'s-v',7X,'d-v',7X,'v-s',7X,'v-d',7X,'v-v')
27609          IF (ICSAMP.GT.0) THEN
27610          WRITE(LOUT,1016)
27611      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=0,1),
27612      &                 (DBLE(ICCHAI(2,I))/(2.0D0*DBLE(ICSAMP)),I=4,8),
27613      &                 ((DBLE(ICEVTG(I,J))/DBLE(ICSAMP),I=4,8),J=2,18)
27614  1016    FORMAT(/,1X,'req.to.    ',5E10.2,/,/,1X,'low rq.    ',5E10.2,/,
27615      &          1X,'low ac.    ',5E10.2,/,/,1X,'PHOJET     ',5E10.2,/,/,
27616      &          ' no-dif.    ',5E10.2,/,' el-sca.    ',5E10.2,/,
27617      &          ' qel-sc.    ',5E10.2,/,' dbl-Po.    ',5E10.2,/,
27618      &          ' diff-1     ',5E10.2,/,' diff-2     ',5E10.2,/,
27619      &          ' dbl-di.    ',5E10.2,/,' dir-ga.    ',5E10.2,/,/,
27620      &          ' dir-1      ',5E10.2,/,' dir-2      ',5E10.2,/,
27621      &          ' dbl-dir    ',5E10.2,/,' s-Pom.     ',5E10.2,/,
27622      &          ' h-Pom.     ',5E10.2,/,' s-Reg.     ',5E10.2,/,
27623      &          ' enh-trg    ',5E10.2,/,' enh-log    ',5E10.2)
27624          ENDIF
27625
27626       ENDIF
27627       CALL DT_CHASTA(1)
27628
27629       IF ((PDBSEA(1).GT.0.0D0).OR.(PDBSEA(2).GT.0.0D0)
27630      &                        .OR.(PDBSEA(3).GT.0.0D0)) THEN
27631          WRITE(LOUT,*)'YGS1S,YGS2S,YUS1S,YUS2S',
27632      &    DBRKA(1,1)+DBRKA(2,1),DBRKA(1,2)+DBRKA(2,2),
27633      &    DBRKA(1,3)+DBRKA(2,3),DBRKA(1,4)+DBRKA(2,4)
27634          WRITE(LOUT,*)'YGS1R,YGS2R,YUS1R,YUS2R',
27635      &    DBRKR(1,1)+DBRKR(2,1),DBRKR(1,2)+DBRKR(2,2),
27636      &    DBRKR(1,3)+DBRKR(2,3),DBRKR(1,4)+DBRKR(2,4)
27637          WRITE(LOUT,*)'YGSA1S,YGSA2S,YUSA1S,YUSA2S',
27638      &    DBRKA(1,5)+DBRKA(2,5),DBRKA(1,6)+DBRKA(2,6),
27639      &    DBRKA(1,7)+DBRKA(2,7),DBRKA(1,8)+DBRKA(2,8)
27640          WRITE(LOUT,*)'YGSA1R,YGSA2R,YUSA1R,YUSA2R',
27641      &    DBRKR(1,5)+DBRKR(2,5),DBRKR(1,6)+DBRKR(2,6),
27642      &    DBRKR(1,7)+DBRKR(2,7),DBRKR(1,8)+DBRKR(2,8)
27643          WRITE(LOUT,*)'YG31S,YG32S,YU31S,YU32S',
27644      &    DBRKA(3,1),DBRKA(3,2),
27645      &    DBRKA(3,3),DBRKA(3,4)
27646          WRITE(LOUT,*)'YG31R,YG32R,YU31R,YU32R',
27647      &    DBRKR(3,1),DBRKR(3,2),
27648      &    DBRKR(3,3),DBRKR(3,4)
27649          WRITE(LOUT,*)'YG3A1S,YG3A2S,YU3A1S,YU3A2S',
27650      &    DBRKA(3,5),DBRKA(3,6),
27651      &    DBRKA(3,7),DBRKA(3,8)
27652          WRITE(LOUT,*)'YG3A1R,YG3A2R,YU3A1R,YU3A2R',
27653      &    DBRKR(3,5),DBRKR(3,6),
27654      &    DBRKR(3,7),DBRKR(3,8)
27655       ENDIF
27656
27657       FAC = 1.0D0
27658       IF (MCGENE.EQ.2) THEN
27659
27660 C        CALL PHO_PHIST(-2,SIGMAX)
27661          CALL PHO_EVENT(-2,PP,PT,FAC,IREJ1)
27662
27663       ENDIF
27664
27665       CALL DT_XTIME
27666
27667       RETURN
27668       END
27669
27670 *$ CREATE DT_EVTOUT.FOR
27671 *COPY DT_EVTOUT
27672 *
27673 *===evtout=============================================================*
27674 *
27675       SUBROUTINE DT_EVTOUT(MODE)
27676
27677 ************************************************************************
27678 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27679 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27680 *                    4  plot entries of DTEVT1 and DTEVT2              *
27681 * This version dated 11.12.94 is written by S. Roesler                 *
27682 ************************************************************************
27683
27684       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27685       SAVE
27686
27687       PARAMETER ( LINP = 10 ,
27688      &            LOUT = 6 ,
27689      &            LDAT = 9 )
27690
27691 * event history
27692
27693       PARAMETER (NMXHKK=200000)
27694
27695       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27696      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27697      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27698
27699       DIMENSION IRANGE(NMXHKK)
27700
27701       IF (MODE.EQ.2) RETURN
27702
27703       CALL DT_EVTPLO(IRANGE,MODE)
27704
27705       RETURN
27706       END
27707
27708 *$ CREATE DT_EVTPLO.FOR
27709 *COPY DT_EVTPLO
27710 *
27711 *===evtplo=============================================================*
27712 *
27713       SUBROUTINE DT_EVTPLO(IRANGE,MODE)
27714
27715 ************************************************************************
27716 *            MODE  = 1  plot content of complete DTEVT1 to out. unit   *
27717 *                    2  plot entries of DTEVT1 given by IRANGE         *
27718 *                    3  plot entries of extended DTEVT1 (DTEVT2)       *
27719 *                    4  plot entries of DTEVT1 and DTEVT2              *
27720 *                    5  plot rejection counter                         *
27721 * This version dated 11.12.94 is written by S. Roesler                 *
27722 ************************************************************************
27723
27724       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27725       SAVE
27726
27727       PARAMETER ( LINP = 10 ,
27728      &            LOUT = 6 ,
27729      &            LDAT = 9 )
27730
27731       CHARACTER*16 CHAU
27732
27733 * event history
27734
27735       PARAMETER (NMXHKK=200000)
27736
27737       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27738      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27739      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27740
27741 * extended event history
27742       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27743      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27744      &                IHIST(2,NMXHKK)
27745
27746 * rejection counter
27747       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
27748      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
27749      &                IREXCI(3),IRDIFF(2),IRINC
27750
27751       DIMENSION IRANGE(NMXHKK)
27752
27753       IF ((MODE.EQ.1).OR.(MODE.EQ.4)) THEN
27754          WRITE(LOUT,1000)
27755  1000    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTEVT1/',/,
27756      &         15X,'           --------------------------',/,/,
27757      &             '       ST    ID  M1   M2   D1   D2     PX     PY',
27758      &             '     PZ      E       M',/)
27759          DO 1 I=1,NHKK
27760             WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27761      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27762      &                       PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27763      &                       PHKK(5,I)
27764 C           WRITE(LOUT,1011) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27765 C    &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27766 C    &                       PHKK(3,I),PHKK(4,I)
27767 C           WRITE(LOUT,'(4E15.4)')
27768 C    &         VHKK(1,I),VHKK(2,I),VHKK(3,I),VHKK(4,I)
27769  1001       FORMAT(I5,I5,I6,4I5,3F7.3,F8.3,F8.4)
27770  1011       FORMAT(I5,I5,I6,4I5,2E15.5)
27771     1    CONTINUE
27772          WRITE(LOUT,*)
27773 C        DO 4 I=1,NHKK
27774 C           WRITE(LOUT,1006) I,ISTHKK(I),
27775 C    &                    VHKK(1,I),VHKK(2,I),VHKK(3,I),WHKK(1,I),
27776 C    &                    WHKK(2,I),WHKK(3,I)
27777 C1006       FORMAT(1X,I4,I6,6E10.3)
27778 C   4    CONTINUE
27779       ENDIF
27780
27781       IF (MODE.EQ.2) THEN
27782          WRITE(LOUT,1000)
27783          NC = 0
27784     2    CONTINUE
27785          NC = NC+1
27786          IF (IRANGE(NC).EQ.-100) GOTO 9999
27787          I = IRANGE(NC)
27788          WRITE(LOUT,1001) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27789      &                    JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27790      &                    PHKK(1,I),PHKK(2,I),PHKK(3,I),PHKK(4,I),
27791      &                    PHKK(5,I)
27792          GOTO 2
27793       ENDIF
27794
27795       IF ((MODE.EQ.3).OR.(MODE.EQ.4)) THEN
27796          WRITE(LOUT,1002)
27797  1002    FORMAT(/,1X,'EVTPLO:',14X,
27798      &         ' content of COMMON /DTEVT1/,/DTEVT2/',/,
27799      &         15X,'        -----------------------------------',/,/,
27800      &             '       ST    ID   M1   M2   D1   D2  IDR  IDXR',
27801      &             ' NOBAM IDCH    M',/)
27802          DO 3 I=1,NHKK
27803 C           IF ((ISTHKK(I).GT.10).OR.(ISTHKK(I).EQ.1)) THEN
27804                KF    = IDHKK(I)
27805                IDCHK = KF/10000
27806                IF ((((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
27807      &            (KF.NE.80000)).OR.(IDHKK(I).EQ.99999)) KF = 92
27808
27809                CALL PYNAME(KF,CHAU)
27810
27811                WRITE(LOUT,1003) I,ISTHKK(I),IDHKK(I),JMOHKK(1,I),
27812      &                       JMOHKK(2,I),JDAHKK(1,I),JDAHKK(2,I),
27813      &                       IDRES(I),IDXRES(I),NOBAM(I),IDCH(I),
27814      &                       PHKK(5,I),CHAU
27815  1003          FORMAT(I5,I5,I6,4I5,4I4,F8.4,2X,A)
27816 C           ENDIF
27817     3    CONTINUE
27818       ENDIF
27819
27820       IF (MODE.EQ.5) THEN
27821          WRITE(LOUT,1004)
27822  1004    FORMAT(/,1X,'EVTPLO:',14X,'    content of COMMON /DTREJC/',/,
27823      &         15X,'           --------------------------',/)
27824          WRITE(LOUT,1005) IRPT,IRHHA,IRRES,LOMRES,LOBRES,IREMC,IRFRAG,
27825      &                    IRSEA,IRCRON
27826  1005    FORMAT(1X,'IRPT   = ',I5,'  IRHHA = ',I5,/,
27827      &          1X,'IRRES  = ',2I5,'  LOMRES = ',I5,'  LOBRES = ',I5,/,
27828      &          1X,'IREMC  = ',10I5,/,
27829      &          1X,'IRFRAG = ',I5,'  IRSEA = ',I5,' IRCRON = ',I5,/)
27830       ENDIF
27831
27832  9999 RETURN
27833       END
27834
27835 *$ CREATE DT_EVTPUT.FOR
27836 *COPY DT_EVTPUT
27837 *
27838 *===evtput=============================================================*
27839 *
27840       SUBROUTINE DT_EVTPUT(IST,ID,M1,M2,PX,PY,PZ,E,IDR,IDXR,IDC)
27841
27842       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
27843       SAVE
27844
27845       PARAMETER ( LINP = 10 ,
27846      &            LOUT = 6 ,
27847      &            LDAT = 9 )
27848
27849       PARAMETER (TINY10=1.0D-10,TINY4=1.0D-4,TINY3=1.0D-3,
27850      &           TINY2=1.0D-2,SQTINF=1.0D+15,ZERO=0.0D0)
27851
27852 * event history
27853
27854       PARAMETER (NMXHKK=200000)
27855
27856       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
27857      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
27858      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
27859
27860 * extended event history
27861       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
27862      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
27863      &                IHIST(2,NMXHKK)
27864
27865 * Lorentz-parameters of the current interaction
27866       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
27867      &                UMO,PPCM,EPROJ,PPROJ
27868
27869 * particle properties (BAMJET index convention)
27870       CHARACTER*8  ANAME
27871       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
27872      &                IICH(210),IIBAR(210),K1(210),K2(210)
27873
27874 C     IF (MODE.GT.100) THEN
27875 C        WRITE(LOUT,'(1X,A,I5,A,I5)')
27876 C    &        'EVTPUT: reset NHKK = ',NHKK,' to NHKK =',NHKK-MODE+100
27877 C        NHKK = NHKK-MODE+100
27878 C        RETURN
27879 C     ENDIF
27880       MO1  = M1
27881       MO2  = M2
27882       NHKK = NHKK+1
27883
27884       IF (NHKK.GT.NMXHKK) THEN
27885          WRITE(LOUT,1000) NHKK
27886  1000    FORMAT(1X,'EVTPUT: NHKK exeeds NMXHKK = ',I7,
27887      &             '! program execution stopped..')
27888          STOP
27889       ENDIF
27890       IF (M1.LT.0) MO1 = NHKK+M1
27891       IF (M2.LT.0) MO2 = NHKK+M2
27892       ISTHKK(NHKK)   = IST
27893       IDHKK(NHKK)    = ID
27894       JMOHKK(1,NHKK) = MO1
27895       JMOHKK(2,NHKK) = MO2
27896       JDAHKK(1,NHKK) = 0
27897       JDAHKK(2,NHKK) = 0
27898       IDRES(NHKK)    = IDR
27899       IDXRES(NHKK)   = IDXR
27900       IDCH(NHKK)     = IDC
27901 ** here we need to do something..
27902       IF (ID.EQ.88888) THEN
27903          IDMO1 = ABS(IDHKK(MO1))
27904          IDMO2 = ABS(IDHKK(MO2))
27905          IF ((IDMO1.LT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 3
27906          IF ((IDMO1.LT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 4
27907          IF ((IDMO1.GT.100).AND.(IDMO2.GT.100)) NOBAM(NHKK) = 5
27908          IF ((IDMO1.GT.100).AND.(IDMO2.LT.100)) NOBAM(NHKK) = 6
27909       ELSE
27910          NOBAM(NHKK) = 0
27911       ENDIF
27912       IDBAM(NHKK) = IDT_ICIHAD(ID)
27913       IF (MO1.GT.0) THEN
27914          IF (JDAHKK(1,MO1).NE.0) THEN
27915             JDAHKK(2,MO1) = NHKK
27916          ELSE
27917             JDAHKK(1,MO1) = NHKK
27918          ENDIF
27919       ENDIF
27920       IF (MO2.GT.0) THEN
27921          IF (JDAHKK(1,MO2).NE.0) THEN
27922             JDAHKK(2,MO2) = NHKK
27923          ELSE
27924             JDAHKK(1,MO2) = NHKK
27925          ENDIF
27926       ENDIF
27927 C      IF ((IDBAM(NHKK).GT.0).AND.(IDBAM(NHKK).NE.7)) THEN
27928 C         PTOT   = SQRT(PX**2+PY**2+PZ**2)
27929 C         AM0    = SQRT(ABS( (E-PTOT)*(E+PTOT) ))
27930 C         AMRQ   = AAM(IDBAM(NHKK))
27931 C         AMDIF2 = (AM0-AMRQ)*(AM0+AMRQ)
27932 C         IF ((ABS(AMDIF2).GT.TINY3).AND.(E.LT.SQTINF).AND.
27933 C     &       (PTOT.GT.ZERO)) THEN
27934 C            DELTA = -AMDIF2/(2.0D0*(E+PTOT))
27935 CC           DELTA = (AMRQ2-AM2)/(2.0D0*(E+PTOT))
27936 C            E     = E+DELTA
27937 C            PTOT1 = PTOT-DELTA
27938 C            PX    = PX*PTOT1/PTOT
27939 C            PY    = PY*PTOT1/PTOT
27940 C            PZ    = PZ*PTOT1/PTOT
27941 C         ENDIF
27942 C      ENDIF
27943       PHKK(1,NHKK) = PX
27944       PHKK(2,NHKK) = PY
27945       PHKK(3,NHKK) = PZ
27946       PHKK(4,NHKK) = E
27947       PTOT = SQRT( PX**2+PY**2+PZ**2 )
27948       IF ((IDHKK(NHKK).GE.22).AND.(IDHKK(NHKK).LE.24)) THEN
27949          PHKK(5,NHKK) = PHKK(4,NHKK)**2-PTOT**2
27950          PHKK(5,NHKK) = SIGN(SQRT(ABS(PHKK(5,NHKK))),PHKK(5,NHKK))
27951       ELSE
27952          PHKK(5,NHKK) = (PHKK(4,NHKK)-PTOT)*(PHKK(4,NHKK)+PTOT)
27953 C        IF ((PHKK(5,NHKK).LT.0.0D0).AND.(ABS(PHKK(5,NHKK)).GT.TINY4))
27954 C    &      WRITE(LOUT,'(1X,A,G10.3)')
27955 C    &        'EVTPUT: negative mass**2 ',PHKK(5,NHKK)
27956          PHKK(5,NHKK) = SQRT(ABS(PHKK(5,NHKK)))
27957       ENDIF
27958       IDCHK = ID/10000
27959       IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.(ID.NE.80000)) THEN
27960 * special treatment for chains:
27961 *    z coordinate of chain in Lab  = pos. of target nucleon
27962 *    time of chain-creation in Lab = time of passage of projectile
27963 *                                    nucleus at pos. of taget nucleus
27964 C        VHKK(1,NHKK) = 0.5D0*(VHKK(1,MO1)+VHKK(1,MO2))
27965 C        VHKK(2,NHKK) = 0.5D0*(VHKK(2,MO1)+VHKK(2,MO2))
27966          VHKK(1,NHKK) = VHKK(1,MO2)
27967          VHKK(2,NHKK) = VHKK(2,MO2)
27968          VHKK(3,NHKK) = VHKK(3,MO2)
27969          VHKK(4,NHKK) = VHKK(3,MO2)/BLAB-VHKK(3,MO1)/BGLAB
27970 C        WHKK(1,NHKK) = 0.5D0*(WHKK(1,MO1)+WHKK(1,MO2))
27971 C        WHKK(2,NHKK) = 0.5D0*(WHKK(2,MO1)+WHKK(2,MO2))
27972          WHKK(1,NHKK) = WHKK(1,MO1)
27973          WHKK(2,NHKK) = WHKK(2,MO1)
27974          WHKK(3,NHKK) = WHKK(3,MO1)
27975          WHKK(4,NHKK) = -WHKK(3,MO1)/BLAB+WHKK(3,MO2)/BGLAB
27976       ELSE
27977          IF (MO1.GT.0) THEN
27978             DO 1 I=1,4
27979                VHKK(I,NHKK) = VHKK(I,MO1)
27980                WHKK(I,NHKK) = WHKK(I,MO1)
27981     1       CONTINUE
27982          ELSE
27983             DO 2 I=1,4
27984                VHKK(I,NHKK) = ZERO
27985                WHKK(I,NHKK) = ZERO
27986     2       CONTINUE
27987          ENDIF
27988       ENDIF
27989
27990       RETURN
27991       END
27992
27993 *$ CREATE DT_CHASTA.FOR
27994 *COPY DT_CHASTA
27995 *
27996 *===chasta=============================================================*
27997 *
27998       SUBROUTINE DT_CHASTA(MODE)
27999
28000 ************************************************************************
28001 * This subroutine performs CHAin STAtistics and checks sequence of     *
28002 * partons in dtevt1 and sorts them with projectile partons coming      *
28003 * first if necessary.                                                  *
28004 *                                                                      *
28005 * This version dated  8.5.00  is written by S. Roesler.                *
28006 ************************************************************************
28007
28008       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28009       SAVE
28010
28011       PARAMETER ( LINP = 10 ,
28012      &            LOUT = 6 ,
28013      &            LDAT = 9 )
28014
28015       CHARACTER*5 CCHTYP
28016
28017 * event history
28018
28019       PARAMETER (NMXHKK=200000)
28020
28021       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28022      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28023      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28024
28025 * extended event history
28026       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28027      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28028      &                IHIST(2,NMXHKK)
28029
28030 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
28031       PARAMETER (MAXCHN=10000)
28032       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
28033
28034       DIMENSION ICHCFG(10,10,9,2),ICHTYP(5,5),
28035      &          CCHTYP(9),ICHSTA(10),ITOT(10)
28036       DATA ICHCFG /1800*0/
28037       DATA (ICHTYP(1,K),K=1,5) / 0, 1, 3, 0, 0/
28038       DATA (ICHTYP(2,K),K=1,5) / 2, 0, 0, 5, 0/
28039       DATA (ICHTYP(3,K),K=1,5) / 4, 0, 0, 7, 0/
28040       DATA (ICHTYP(4,K),K=1,5) / 0, 6, 8, 0, 0/
28041       DATA (ICHTYP(5,K),K=1,5) / 0, 0, 0, 0, 9/
28042       DATA ICHSTA / 21, 22, 31, 32, 41, 42, 51, 52, 61, 62/
28043       DATA CCHTYP / ' q aq','aq q ',' q d ',' d q ','aq ad',
28044      &              'ad aq',' d ad','ad d ',' g g '/
28045 *
28046 * initialization
28047 *
28048       IF (MODE.EQ.-1) THEN
28049          NCHAIN = 0
28050 *
28051 * loop over DTEVT1 and analyse chain configurations
28052 *
28053       ELSEIF (MODE.EQ.0) THEN
28054          DO 21 IDX=NPOINT(3),NHKK
28055             IDCHK = IDHKK(IDX)/10000
28056             IF (((IDCHK.EQ.7).OR.(IDCHK.EQ.8)).AND.
28057      &          (IDHKK(IDX).NE.80000).AND.
28058      &          (ISTHKK(IDX).NE.2).AND.(IDRES(IDX).EQ.0)) THEN
28059                IF (JMOHKK(1,IDX).GT.JMOHKK(2,IDX)) THEN
28060                   WRITE(LOUT,*) ' CHASTA: JMOHKK(1,x) > JMOHKK(2,x) ',
28061      &                          ' at entry ',IDX
28062                   GOTO 21
28063                ENDIF
28064 *
28065                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28066                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28067                IMO1 = IST1/10
28068                IMO1 = IST1-10*IMO1
28069                IMO2 = IST2/10
28070                IMO2 = IST2-10*IMO2
28071 *   swop parton entries if necessary since we need projectile partons
28072 *   to come first in the common
28073                IF (IMO1.GT.IMO2) THEN
28074                   NPTN = JMOHKK(2,IDX)-JMOHKK(1,IDX)+1
28075                   DO 22 K=1,NPTN/2
28076                      I0 = JMOHKK(1,IDX)-1+K
28077                      I1 = JMOHKK(2,IDX)+1-K
28078                      ITMP = ISTHKK(I0)
28079                      ISTHKK(I0) = ISTHKK(I1)
28080                      ISTHKK(I1) = ITMP
28081                      ITMP = IDHKK(I0)
28082                      IDHKK(I0) = IDHKK(I1)
28083                      IDHKK(I1) = ITMP
28084                      IF (JDAHKK(1,JMOHKK(1,I0)).EQ.I0)
28085      &                  JDAHKK(1,JMOHKK(1,I0)) = I1
28086                      IF (JDAHKK(2,JMOHKK(1,I0)).EQ.I0)
28087      &                  JDAHKK(2,JMOHKK(1,I0)) = I1
28088                      IF (JDAHKK(1,JMOHKK(2,I0)).EQ.I0)
28089      &                  JDAHKK(1,JMOHKK(2,I0)) = I1
28090                      IF (JDAHKK(2,JMOHKK(2,I0)).EQ.I0)
28091      &                  JDAHKK(2,JMOHKK(2,I0)) = I1
28092                      IF (JDAHKK(1,JMOHKK(1,I1)).EQ.I1)
28093      &                  JDAHKK(1,JMOHKK(1,I1)) = I0
28094                      IF (JDAHKK(2,JMOHKK(1,I1)).EQ.I1)
28095      &                  JDAHKK(2,JMOHKK(1,I1)) = I0
28096                      IF (JDAHKK(1,JMOHKK(2,I1)).EQ.I1)
28097      &                  JDAHKK(1,JMOHKK(2,I1)) = I0
28098                      IF (JDAHKK(2,JMOHKK(2,I1)).EQ.I1)
28099      &                  JDAHKK(2,JMOHKK(2,I1)) = I0
28100                      ITMP = JMOHKK(1,I0)
28101                      JMOHKK(1,I0) = JMOHKK(1,I1)
28102                      JMOHKK(1,I1) = ITMP
28103                      ITMP = JMOHKK(2,I0)
28104                      JMOHKK(2,I0) = JMOHKK(2,I1)
28105                      JMOHKK(2,I1) = ITMP
28106                      ITMP = JDAHKK(1,I0)
28107                      JDAHKK(1,I0) = JDAHKK(1,I1)
28108                      JDAHKK(1,I1) = ITMP
28109                      ITMP = JDAHKK(2,I0)
28110                      JDAHKK(2,I0) = JDAHKK(2,I1)
28111                      JDAHKK(2,I1) = ITMP
28112                      DO 23 J=1,4
28113                         RTMP1 = PHKK(J,I0)
28114                         RTMP2 = VHKK(J,I0)
28115                         RTMP3 = WHKK(J,I0)
28116                         PHKK(J,I0) = PHKK(J,I1)
28117                         VHKK(J,I0) = VHKK(J,I1)
28118                         WHKK(J,I0) = WHKK(J,I1)
28119                         PHKK(J,I1) = RTMP1
28120                         VHKK(J,I1) = RTMP2
28121                         WHKK(J,I1) = RTMP3
28122    23                CONTINUE
28123                      RTMP1 = PHKK(5,I0)
28124                      PHKK(5,I0) = PHKK(5,I1)
28125                      PHKK(5,I1) = RTMP1
28126                      ITMP = IDRES(I0)
28127                      IDRES(I0) = IDRES(I1)
28128                      IDRES(I1) = ITMP
28129                      ITMP = IDXRES(I0)
28130                      IDXRES(I0) = IDXRES(I1)
28131                      IDXRES(I1) = ITMP
28132                      ITMP = NOBAM(I0)
28133                      NOBAM(I0) = NOBAM(I1)
28134                      NOBAM(I1) = ITMP
28135                      ITMP = IDBAM(I0)
28136                      IDBAM(I0) = IDBAM(I1)
28137                      IDBAM(I1) = ITMP
28138                      ITMP = IDCH(I0)
28139                      IDCH(I0) = IDCH(I1)
28140                      IDCH(I1) = ITMP
28141                      ITMP = IHIST(1,I0)
28142                      IHIST(1,I0) = IHIST(1,I1)
28143                      IHIST(1,I1) = ITMP
28144                      ITMP = IHIST(2,I0)
28145                      IHIST(2,I0) = IHIST(2,I1)
28146                      IHIST(2,I1) = ITMP
28147    22             CONTINUE
28148                ENDIF
28149                IST1 = ABS(ISTHKK(JMOHKK(1,IDX)))
28150                IST2 = ABS(ISTHKK(JMOHKK(2,IDX)))
28151 *
28152 *   parton 1 (projectile side)
28153                IF (IST1.EQ.21) THEN
28154                   IDX1 = 1
28155                ELSEIF (IST1.EQ.22) THEN
28156                   IDX1 = 2
28157                ELSEIF (IST1.EQ.31) THEN
28158                   IDX1 = 3
28159                ELSEIF (IST1.EQ.32) THEN
28160                   IDX1 = 4
28161                ELSEIF (IST1.EQ.41) THEN
28162                   IDX1 = 5
28163                ELSEIF (IST1.EQ.42) THEN
28164                   IDX1 = 6
28165                ELSEIF (IST1.EQ.51) THEN
28166                   IDX1 = 7
28167                ELSEIF (IST1.EQ.52) THEN
28168                   IDX1 = 8
28169                ELSEIF (IST1.EQ.61) THEN
28170                   IDX1 = 9
28171                ELSEIF (IST1.EQ.62) THEN
28172                   IDX1 = 10
28173                ELSE
28174 c                 WRITE(LOUT,*)
28175 c    &               ' CHASTA: unknown parton status flag (',
28176 c    &               IST1,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28177                   GOTO 21
28178                ENDIF
28179                ID = IDHKK(JMOHKK(1,IDX))
28180                IF (ABS(ID).LE.4) THEN
28181                   IF (ID.GT.0) THEN
28182                      ITYP1 = 1
28183                   ELSE
28184                      ITYP1 = 2
28185                   ENDIF
28186                ELSEIF (ABS(ID).GE.1000) THEN
28187                   IF (ID.GT.0) THEN
28188                      ITYP1 = 3
28189                   ELSE
28190                      ITYP1 = 4
28191                   ENDIF
28192                ELSEIF (ID.EQ.21) THEN
28193                   ITYP1 = 5
28194                ELSE
28195                   WRITE(LOUT,*)
28196      &               ' CHASTA: inconsistent parton identity (',
28197      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28198                   GOTO 21
28199                ENDIF
28200 *
28201 *   parton 2 (target side)
28202                IF (IST2.EQ.21) THEN
28203                   IDX2 = 1
28204                ELSEIF (IST2.EQ.22) THEN
28205                   IDX2 = 2
28206                ELSEIF (IST2.EQ.31) THEN
28207                   IDX2 = 3
28208                ELSEIF (IST2.EQ.32) THEN
28209                   IDX2 = 4
28210                ELSEIF (IST2.EQ.41) THEN
28211                   IDX2 = 5
28212                ELSEIF (IST2.EQ.42) THEN
28213                   IDX2 = 6
28214                ELSEIF (IST2.EQ.51) THEN
28215                   IDX2 = 7
28216                ELSEIF (IST2.EQ.52) THEN
28217                   IDX2 = 8
28218                ELSEIF (IST2.EQ.61) THEN
28219                   IDX2 = 9
28220                ELSEIF (IST2.EQ.62) THEN
28221                   IDX2 = 10
28222                ELSE
28223 c                 WRITE(LOUT,*)
28224 c    &               ' CHASTA: unknown parton status flag (',
28225 c    &               IST2,') at entry ',JMOHKK(2,IDX),'(',IDX,')'
28226                   GOTO 21
28227                ENDIF
28228                ID = IDHKK(JMOHKK(2,IDX))
28229                IF (ABS(ID).LE.4) THEN
28230                   IF (ID.GT.0) THEN
28231                      ITYP2 = 1
28232                   ELSE
28233                      ITYP2 = 2
28234                   ENDIF
28235                ELSEIF (ABS(ID).GE.1000) THEN
28236                   IF (ID.GT.0) THEN
28237                      ITYP2 = 3
28238                   ELSE
28239                      ITYP2 = 4
28240                   ENDIF
28241                ELSEIF (ID.EQ.21) THEN
28242                   ITYP2 = 5
28243                ELSE
28244                   WRITE(LOUT,*)
28245      &               ' CHASTA: inconsistent parton identity (',
28246      &               ID,') at entry ',JMOHKK(1,IDX),'(',IDX,')'
28247                   GOTO 21
28248                ENDIF
28249 *
28250 *   fill counter
28251                ITYPE = ICHTYP(ITYP1,ITYP2)
28252                IF (ITYPE.NE.0) THEN
28253                   ICHCFG(IDX1,IDX2,ITYPE,1) =ICHCFG(IDX1,IDX2,ITYPE,1)+1
28254                   NGLUON = JMOHKK(2,IDX)-JMOHKK(1,IDX)-1
28255                   ICHCFG(IDX1,IDX2,ITYPE,2) =
28256      &               ICHCFG(IDX1,IDX2,ITYPE,2)+NGLUON
28257
28258                   NCHAIN = NCHAIN+1
28259                   IF (NCHAIN.GT.MAXCHN) THEN
28260                      WRITE(LOUT,*) ' CHASTA: NCHAIN > MAXCHN ! ',
28261      &                  NCHAIN,MAXCHN
28262                      STOP
28263                   ENDIF
28264                   IDXCHN(1,NCHAIN) = IDX
28265                   IDXCHN(2,NCHAIN) = ITYPE
28266                ELSE
28267                   WRITE(LOUT,*)
28268      &               ' CHASTA: inconsistent chain at entry ',IDX
28269                   GOTO 21
28270                ENDIF
28271             ENDIF
28272    21    CONTINUE
28273 *
28274 * write statistics to output unit
28275 *
28276       ELSEIF (MODE.EQ.1) THEN
28277          WRITE(LOUT,'(/,A)') ' CHASTA: generated chain configurations'
28278          DO 31 I=1,10
28279             WRITE(LOUT,'(/,2A)')
28280      &         ' -----------------------------------------',
28281      &         '------------------------------------'
28282             WRITE(LOUT,'(2A)')
28283      &         ' p\\t         21     22     31     32     41',
28284      &         '     42     51     52     61     62'
28285             WRITE(LOUT,'(2A)')
28286      &         ' -----------------------------------------',
28287      &         '------------------------------------'
28288             DO 32 J=1,10
28289                ITOT(J) = 0
28290                DO 33 K=1,9
28291                   ITOT(J) = ITOT(J)+ICHCFG(I,J,K,1)
28292    33          CONTINUE
28293    32       CONTINUE
28294             WRITE(LOUT,'(1X,I2,5X,10I7,/)') ICHSTA(I),(ITOT(J),J=1,10)
28295             DO 34 K=1,9
28296                ISUM = 0
28297                DO 35 J=1,10
28298                   ISUM = ISUM+ICHCFG(I,J,K,1)
28299    35          CONTINUE
28300                IF (ISUM.GT.0)
28301      &            WRITE(LOUT,'(1X,A5,2X,10I7)')
28302      &               CCHTYP(K),(ICHCFG(I,J,K,1),J=1,10)
28303    34       CONTINUE
28304 C           WRITE(LOUT,'(2A)')
28305 C    &         ' -----------------------------------------',
28306 C    &         '-------------------------------'
28307    31    CONTINUE
28308 *
28309       ELSE
28310          WRITE(LOUT,*) ' CHASTA: MODE ',MODE,' not supported !'
28311          STOP
28312       ENDIF
28313
28314       RETURN
28315       END
28316 *$ CREATE PHO_PHIST.FOR
28317 *COPY PHO_PHIST
28318 *
28319 *===pohist=============================================================*
28320 *
28321       SUBROUTINE PHO_PHIST(IMODE,WEIGHT)
28322
28323       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28324       SAVE
28325
28326       PARAMETER ( LINP = 10 ,
28327      &            LOUT = 6 ,
28328      &            LDAT = 9 )
28329
28330       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
28331
28332 * Glauber formalism: cross sections
28333       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
28334      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
28335      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
28336      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
28337      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
28338      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
28339      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
28340      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
28341      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
28342      &                BSLOPE,NEBINI,NQBINI
28343
28344       ILAB = 0
28345       IF (IMODE.EQ.10) THEN
28346          IMODE = 1
28347          ILAB  = 1
28348       ENDIF
28349       IF (ABS(IMODE).LT.1000) THEN
28350 * PHOJET-statistics
28351 C        CALL POHISX(IMODE,WEIGHT)
28352          IF (IMODE.EQ.-1) THEN
28353             MODE = 1
28354             XSTOT(1,1,1) = WEIGHT
28355          ENDIF
28356          IF (IMODE.EQ. 1) MODE = 2
28357          IF (IMODE.EQ.-2) MODE = 3
28358          IF (MODE.EQ.2) CALL DT_SWPPHO(ILAB)
28359 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28360 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28361          CALL DT_HISTOG(MODE)
28362          CALL DT_USRHIS(MODE)
28363       ELSE
28364 * DTUNUC-statistics
28365          MODE = IMODE/1000
28366 C        IF (MODE.EQ.3) WRITE(LOUT,*)
28367 C    &      ' Sigma = ',XSPRO(1,1,1),' mb   used for normalization'
28368          CALL DT_HISTOG(MODE)
28369          CALL DT_USRHIS(MODE)
28370       ENDIF
28371
28372       RETURN
28373       END
28374
28375 *$ CREATE DT_SWPPHO.FOR
28376 *COPY DT_SWPPHO
28377 *
28378 *===swppho=============================================================*
28379 *
28380       SUBROUTINE DT_SWPPHO(ILAB)
28381
28382       IMPLICIT DOUBLE PRECISION (A-H,O-X,Z)
28383       SAVE
28384
28385       PARAMETER ( LINP = 10 ,
28386      &            LOUT = 6 ,
28387      &            LDAT = 9 )
28388
28389       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28390
28391       LOGICAL LSTART
28392
28393 * event history
28394
28395       PARAMETER (NMXHKK=200000)
28396
28397       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28398      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28399      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28400
28401 * extended event history
28402       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28403      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28404      &                IHIST(2,NMXHKK)
28405
28406 * flags for input different options
28407       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28408       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28409      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28410
28411 * properties of photon/lepton projectiles
28412       COMMON /DTGPRO/ VIRT,PGAMM(4),PLEPT0(4),PLEPT1(4),PNUCL(4),IDIREC
28413
28414 **PHOJET105a
28415 C     PARAMETER (NMXHEP=2000)
28416 C     COMMON/HEPEVS/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28417 C    &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
28418 C     COMMON /GLOCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28419 C     COMMON /PLASAV/ PLAB
28420 **PHOJET110
28421 C  standard particle data interface
28422       INTEGER NMXHEP
28423
28424       PARAMETER (NMXHEP=4000)
28425
28426       INTEGER NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
28427       DOUBLE PRECISION PHEP,VHEP
28428       COMMON /POEVT1/ NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
28429      &                JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),
28430      &                VHEP(4,NMXHEP)
28431 C  extension to standard particle data interface (PHOJET specific)
28432       INTEGER IMPART,IPHIST,ICOLOR
28433       COMMON /POEVT2/ IMPART(NMXHEP),IPHIST(2,NMXHEP),ICOLOR(2,NMXHEP)
28434
28435 C  global event kinematics and particle IDs
28436       INTEGER IFPAP,IFPAB
28437       DOUBLE PRECISION ECM,PCM,PMASS,PVIRT
28438       COMMON /POGCMS/ ECM,PCM,PMASS(2),PVIRT(2),IFPAP(2),IFPAB(2)
28439 **
28440       DATA ICOUNT/0/
28441
28442       DATA LSTART /.TRUE./
28443
28444 C     IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0).AND.LSTART) THEN
28445       IF ((IFRAME.EQ.1).AND.LSTART) THEN
28446          UMO  = ECM
28447          ELA  = ZERO
28448          PLA  = ZERO
28449          IDP  = IDT_ICIHAD(IFPAP(1))
28450          IDT  = IDT_ICIHAD(IFPAP(2))
28451          VIRT = PVIRT(1)
28452          CALL DT_LTINI(IDP,IDT,ELA,PLA,UMO,0)
28453          PLAB = PLA
28454          LSTART = .FALSE.
28455       ENDIF
28456
28457       NHKK   = 0
28458       ICOUNT = ICOUNT+1
28459 C     NEVHKK = NEVHEP
28460       NEVHKK = ICOUNT
28461       IF (MOD(ICOUNT,500).EQ.0) WRITE(LOUT,*)' SWPPHO: event # ',ICOUNT
28462       DO 1 I=3,NHEP
28463          IF (ISTHEP(I).EQ.1) THEN
28464             NHKK = NHKK+1
28465             ISTHKK(NHKK) = 1
28466             IDHKK(NHKK)  = IDHEP(I)
28467             JMOHKK(1,NHKK) = 0
28468             JMOHKK(2,NHKK) = 0
28469             JDAHKK(1,NHKK) = 0
28470             JDAHKK(2,NHKK) = 0
28471             DO 2 K=1,4
28472                PHKK(K,NHKK) = PHEP(K,I)
28473                VHKK(K,NHKK) = ZERO
28474                WHKK(K,NHKK) = ZERO
28475     2       CONTINUE
28476             IF ((IFRAME.EQ.1).AND.(ILAB.EQ.0))
28477      &         CALL DT_LTNUC(PHEP(3,I),PHEP(4,I),
28478      &                    PHKK(3,NHKK),PHKK(4,NHKK),-3)
28479             PHKK(5,NHKK) = PHEP(5,I)
28480             IDRES(NHKK)  = 0
28481             IDXRES(NHKK) = 0
28482             NOBAM(NHKK)  = 0
28483             IDBAM(NHKK)  = IDT_ICIHAD(IDHEP(I))
28484             IDCH(NHKK)   = 0
28485          ENDIF
28486     1 CONTINUE
28487
28488       RETURN
28489       END
28490
28491 *$ CREATE DT_HISTOG.FOR
28492 *COPY DT_HISTOG
28493 *
28494 *===histog=============================================================*
28495 *
28496       SUBROUTINE DT_HISTOG(MODE)
28497
28498 ************************************************************************
28499 * This version dated 25.03.96 is written by S. Roesler                 *
28500 ************************************************************************
28501
28502       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28503       SAVE
28504
28505       PARAMETER ( LINP = 10 ,
28506      &            LOUT = 6 ,
28507      &            LDAT = 9 )
28508
28509       LOGICAL LFSP,LRNL
28510
28511 * event history
28512
28513       PARAMETER (NMXHKK=200000)
28514
28515       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28516      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28517      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28518
28519 * extended event history
28520       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28521      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28522      &                IHIST(2,NMXHKK)
28523
28524 * event flag used for histograms
28525       COMMON /DTNORM/ ICEVT,IEVHKK
28526
28527 * flags for activated histograms
28528       COMMON /DTHIS3/ IHISPP(50),IHISXS(50),IXSTBL
28529
28530       IEVHKK = NEVHKK
28531       GOTO (1,2,3) MODE
28532
28533 *------------------------------------------------------------------
28534 * initialization
28535     1 CONTINUE
28536       ICEVT = 0
28537       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,1)
28538       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(1)
28539
28540       RETURN
28541 *------------------------------------------------------------------
28542 * filling of histogram with event-record
28543     2 CONTINUE
28544       ICEVT = ICEVT+1
28545
28546       DO 20 I=1,NHKK
28547          CALL DT_SWPFSP(I,LFSP,LRNL)
28548          IF (LFSP) THEN
28549             IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,2)
28550             IF (IHISPP(2).EQ.1) CALL DT_HIMULT(2)
28551          ENDIF
28552          IF (IHISPP(1).EQ.1) CALL DT_HISTAT(I,5)
28553    20 CONTINUE
28554       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,4)
28555
28556       RETURN
28557 *------------------------------------------------------------------
28558 * output
28559     3 CONTINUE
28560       IF (IHISPP(1).EQ.1) CALL DT_HISTAT(IDUM,3)
28561       IF (IHISPP(2).EQ.1) CALL DT_HIMULT(3)
28562
28563       RETURN
28564       END
28565
28566 *$ CREATE DT_SWPFSP.FOR
28567 *COPY DT_SWPFSP
28568 *
28569 *===swpfsp=============================================================*
28570 *
28571       SUBROUTINE DT_SWPFSP(IDX,LFSP,LRNL)
28572
28573       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28574       SAVE
28575       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28576       PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
28577      &           PI   =TWOPI/TWO,
28578      &           BOG  =TWOPI/360.0D0)
28579
28580 * event history
28581
28582       PARAMETER (NMXHKK=200000)
28583
28584       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
28585      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
28586      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
28587
28588 * extended event history
28589       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
28590      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
28591      &                IHIST(2,NMXHKK)
28592
28593 * particle properties (BAMJET index convention)
28594       CHARACTER*8  ANAME
28595       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28596      &                IICH(210),IIBAR(210),K1(210),K2(210)
28597
28598 * Lorentz-parameters of the current interaction
28599       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28600      &                UMO,PPCM,EPROJ,PPROJ
28601
28602 * flags for input different options
28603       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
28604       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
28605      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
28606
28607 *      INCLUDE '(DIMPAR)'
28608 *     Taken from FLUKA
28609       PARAMETER ( MXXRGN =20000 )
28610       PARAMETER ( MXXMDF =  710 )
28611       PARAMETER ( MXXMDE =  702 )
28612       PARAMETER ( MFSTCK =40000 )
28613       PARAMETER ( MESTCK =  100 )
28614       PARAMETER ( MOSTCK = 2000 )
28615       PARAMETER ( MXPRSN =  100 )
28616       PARAMETER ( MXPDPM =  800 )
28617       PARAMETER ( MXPSCS =30000 )
28618       PARAMETER ( MXGLWN =  300 )
28619       PARAMETER ( MXOUTU =   50 )
28620       PARAMETER ( NALLWP =   64 )
28621       PARAMETER ( NELEMX =   80 )
28622       PARAMETER ( MPDPDX =   18 )
28623       PARAMETER ( MXHTTR =  260 )
28624       PARAMETER ( MXSEAX =   20 )
28625       PARAMETER ( MXHTNC = MXSEAX + 1 )
28626       PARAMETER ( ICOMAX = 2400 )
28627       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
28628       PARAMETER ( NSTBIS =  304 )
28629       PARAMETER ( NQSTIS =   46 )
28630       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
28631       PARAMETER ( MXPABL =  120 )
28632       PARAMETER ( IDMAXP =  450 )
28633       PARAMETER ( IDMXDC = 2000 )
28634       PARAMETER ( MXMCIN =  410 )
28635       PARAMETER ( IHYPMX =    4 )
28636       PARAMETER ( MKBMX1 =   11 )
28637       PARAMETER ( MKBMX2 =   11 )
28638       PARAMETER ( MXIRRD = 2500 )
28639       PARAMETER ( MXTRDC = 1500 )
28640       PARAMETER ( NKTL   =   17 )
28641       PARAMETER ( NBLNMX = 40000000 )
28642
28643 *      INCLUDE '(PAREVT)'
28644 *     Taken from FLUKA
28645       PARAMETER ( FRDIFF = 0.2D+00 )
28646       PARAMETER ( ETHSEA = 1.0D+00 )
28647 *
28648       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
28649      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
28650      &        LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
28651      &        LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
28652       COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
28653      &                  LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
28654      &                  LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
28655      &                  LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
28656      &                  LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
28657      &                  LVP2XX, LV2XNW, LNWV2X, LEVFIN
28658
28659 * temporary storage for one final state particle
28660       LOGICAL LFRAG,LGREY,LBLACK
28661       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28662      &                SINTHE,COSTHE,THETA,THECMS,
28663      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28664      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28665      &                LFRAG,LGREY,LBLACK
28666
28667       LOGICAL LFSP,LRNL
28668
28669       LFSP = .FALSE.
28670       LRNL = .FALSE.
28671       ISTRNL = 1000
28672       MULDEF = 1
28673       IF (LEVPRT) ISTRNL = 1001
28674
28675       IF (ABS(ISTHKK(IDX)).EQ.1) THEN
28676          IST    = ISTHKK(IDX)
28677          IDPDG  = IDHKK(IDX)
28678          LFRAG  = .FALSE.
28679          IF (IDHKK(IDX).LT.80000) THEN
28680             IDBJT  = IDBAM(IDX)
28681             IBARY  = IIBAR(IDBJT)
28682             ICHAR  = IICH(IDBJT)
28683             AMASS  = AAM(IDBJT)
28684          ELSEIF (IDHKK(IDX).EQ.80000) THEN
28685             IDBJT  = 0
28686             IBARY  = IDRES(IDX)
28687             ICHAR  = IDXRES(IDX)
28688             AMASS  = PHKK(5,IDX)
28689             INUT   = IBARY-ICHAR
28690             IF ((ICHAR.EQ.1).AND.(INUT.EQ.1)) IDBJT = 116
28691             IF ((ICHAR.EQ.1).AND.(INUT.EQ.2)) IDBJT = 117
28692             IF ((ICHAR.EQ.2).AND.(INUT.EQ.1)) IDBJT = 118
28693             IF ((ICHAR.EQ.2).AND.(INUT.EQ.2)) IDBJT = 119
28694             IF (IDBJT.EQ.0) LFRAG = .TRUE.
28695          ELSE
28696             GOTO 9999
28697          ENDIF
28698          PE     = PHKK(4,IDX)
28699          PX     = PHKK(1,IDX)
28700          PY     = PHKK(2,IDX)
28701          PZ     = PHKK(3,IDX)
28702          PT2    = PX**2+PY**2
28703          PT     = SQRT(PT2)
28704          PTOT   = SQRT(PT2+PZ**2)
28705          SINTHE = PT/MAX(PTOT,TINY14)
28706          COSTHE = PZ/MAX(PTOT,TINY14)
28707          IF (COSTHE.GT.ONE) THEN
28708             THETA = ZERO
28709          ELSEIF (COSTHE.LT.-ONE) THEN
28710             THETA = TWOPI/2.0D0
28711          ELSE
28712             THETA = ACOS(COSTHE)
28713          ENDIF
28714          EKIN   = PE-AMASS
28715 **sr 15.4.96 new E_t-definition
28716          IF (IBARY.GT.0) THEN
28717             ET = EKIN*SINTHE
28718          ELSEIF (IBARY.LT.0) THEN
28719             ET = (EKIN+TWO*AMASS)*SINTHE
28720          ELSE
28721             ET = PE*SINTHE
28722          ENDIF
28723 **
28724          XLAB   = PZ/MAX(PPROJ,TINY14)
28725 C        XLAB   = PE/MAX(EPROJ,TINY14)
28726          BETA   = SQRT(ABS( (ONE-AMASS/MAX(PE,TINY14))
28727      &                     *(ONE+AMASS/MAX(PE,TINY14)) ))
28728          PPLUS  = PE+PZ
28729          PMINUS = PE-PZ
28730          IF (PMINUS.GT.TINY14) THEN
28731             YY = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28732          ELSE
28733             YY = 100.0D0
28734          ENDIF
28735          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28736             ETA = -LOG(TAN(THETA/TWO))
28737          ELSE
28738             ETA = 100.0D0
28739          ENDIF
28740          IF (IFRAME.EQ.1) THEN
28741             CALL DT_LTNUC(PZ,PE,PZCMS,EECMS,3)
28742             PPLUS  = EECMS+PZCMS
28743             PMINUS = EECMS-PZCMS
28744             IF ((PPLUS*PMINUS).GT.TINY14) THEN
28745                YYCMS = 0.5D0*LOG(ABS(PPLUS/PMINUS))
28746             ELSE
28747                YYCMS = 100.0D0
28748             ENDIF
28749             PTOTCM = SQRT(PT2+PZCMS**2)
28750             COSTH = PZCMS/MAX(PTOTCM,TINY14)
28751             IF (COSTH.GT.ONE) THEN
28752                THECMS = ZERO
28753             ELSEIF (COSTH.LT.-ONE) THEN
28754                THECMS = TWOPI/2.0D0
28755             ELSE
28756                THECMS = ACOS(COSTH)
28757             ENDIF
28758             IF ((THECMS.GT.TINY14).AND.((PI-THECMS).GT.TINY14)) THEN
28759                ETACMS = -LOG(TAN(THECMS/TWO))
28760             ELSE
28761                ETACMS = 100.0D0
28762             ENDIF
28763             XF = PZCMS/MAX(PPCM,TINY14)
28764             THECMS = THECMS/BOG
28765          ELSE
28766             PZCMS  = PZ
28767             EECMS  = PE
28768             YYCMS  = YY
28769             ETACMS = ETA
28770             XF     = XLAB
28771             THECMS = THETA/BOG
28772          ENDIF
28773          THETA  = THETA/BOG
28774
28775 * set flag for "grey/black"
28776          LGREY  = .FALSE.
28777          LBLACK = .FALSE.
28778          EK     = EKIN
28779          IF (IDHKK(IDX).EQ.80000) EK = EKIN/DBLE(IBARY)
28780          IF (MULDEF.EQ.1) THEN
28781 *  EMU01-Def.
28782             IF ( ( (IDBJT.EQ. 1).AND.(EK.GT. 26.0D-3).AND.
28783      &                              (EK.LE.375.0D-3)      ).OR.
28784      &           ( (IDBJT.EQ.13).AND.(EK.GT. 12.0D-3).AND.
28785      &                              (EK.LE. 56.0D-3)      ).OR.
28786      &           ( (IDBJT.EQ.14).AND.(EK.GT. 12.0D-3).AND.
28787      &                              (EK.LE. 56.0D-3)      ).OR.
28788      &           ( (IDBJT.EQ.15).AND.(EK.GT. 20.0D-3).AND.
28789      &                              (EK.LE.198.0D-3)      ).OR.
28790      &           ( (IDBJT.EQ.16).AND.(EK.GT. 20.0D-3).AND.
28791      &                              (EK.LE.198.0D-3)      ).OR.
28792      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28793      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28794      &             (IDBJT.NE.16).AND.
28795      &             (BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)    ) )
28796      &         LGREY = .TRUE.
28797             IF ( ( (IDBJT.EQ. 1).AND.(EK.LE. 26.0D-3) ).OR.
28798      &           ( (IDBJT.EQ.13).AND.(EK.LE. 12.0D-3) ).OR.
28799      &           ( (IDBJT.EQ.14).AND.(EK.LE. 12.0D-3) ).OR.
28800      &           ( (IDBJT.EQ.15).AND.(EK.LE. 20.0D-3) ).OR.
28801      &           ( (IDBJT.EQ.16).AND.(EK.LE. 20.0D-3) ).OR.
28802      &           ( (IDBJT.NE. 1).AND.(IDBJT.NE.13).AND.
28803      &             (IDBJT.NE.14).AND.(IDBJT.NE.15).AND.
28804      &             (IDBJT.NE.16).AND.(BETA.LE.0.23D0)  ) )
28805      &         LBLACK = .TRUE.
28806          ELSE
28807 *  common Def.
28808             IF ((BETA.GT.0.23D0).AND.(BETA.LE.0.70D0)) LGREY=.TRUE.
28809             IF (BETA.LE.0.23D0) LBLACK=.TRUE.
28810          ENDIF
28811          LFSP = .TRUE.
28812       ELSEIF (ABS(ISTHKK(IDX)).EQ.ISTRNL) THEN
28813          IST    = ISTHKK(IDX)
28814          IDPDG  = IDHKK(IDX)
28815          LFRAG  = .TRUE.
28816          IDBJT  = 0
28817          IBARY  = IDRES(IDX)
28818          ICHAR  = IDXRES(IDX)
28819          AMASS  = PHKK(5,IDX)
28820          PE     = PHKK(4,IDX)
28821          PX     = PHKK(1,IDX)
28822          PY     = PHKK(2,IDX)
28823          PZ     = PHKK(3,IDX)
28824          PT2    = PX**2+PY**2
28825          PT     = SQRT(PT2)
28826          PTOT   = SQRT(PT2+PZ**2)
28827          SINTHE = PT/MAX(PTOT,TINY14)
28828          COSTHE = PZ/MAX(PTOT,TINY14)
28829          IF (COSTHE.GT.ONE) THEN
28830             THETA = ZERO
28831          ELSEIF (COSTHE.LT.-ONE) THEN
28832             THETA = TWOPI/2.0D0
28833          ELSE
28834             THETA  = ACOS(COSTHE)
28835          ENDIF
28836          EKIN   = PE-AMASS
28837 **sr 15.4.96 new E_t-definition
28838 C        ET     = PE*SINTHE
28839          ET     = EKIN*SINTHE
28840 **
28841          IF ((THETA.GT.TINY14).AND.((PI-THETA).GT.TINY14)) THEN
28842             ETA = -LOG(TAN(THETA/TWO))
28843          ELSE
28844             ETA = 100.0D0
28845          ENDIF
28846          THETA  = THETA/BOG
28847          LRNL   = .TRUE.
28848       ENDIF
28849
28850  9999 CONTINUE
28851       RETURN
28852       END
28853
28854 *$ CREATE DT_HIMULT.FOR
28855 *COPY DT_HIMULT
28856 *
28857 *===himult=============================================================*
28858 *
28859       SUBROUTINE DT_HIMULT(MODE)
28860
28861 ************************************************************************
28862 * Tables of average energies/multiplicities.                           *
28863 * This version dated 30.08.2000 is written by S. Roesler               *
28864 ************************************************************************
28865
28866       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
28867       SAVE
28868
28869       PARAMETER ( LINP = 10 ,
28870      &            LOUT = 6 ,
28871      &            LDAT = 9 )
28872
28873       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
28874
28875       PARAMETER (SWMEXP=1.7D0)
28876
28877       CHARACTER*8 ANAMEH(4)
28878
28879 * particle properties (BAMJET index convention)
28880       CHARACTER*8  ANAME
28881       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
28882      &                IICH(210),IIBAR(210),K1(210),K2(210)
28883
28884 * temporary storage for one final state particle
28885       LOGICAL LFRAG,LGREY,LBLACK
28886       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
28887      &                SINTHE,COSTHE,THETA,THECMS,
28888      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
28889      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
28890      &                LFRAG,LGREY,LBLACK
28891
28892 * event flag used for histograms
28893       COMMON /DTNORM/ ICEVT,IEVHKK
28894
28895 * Lorentz-parameters of the current interaction
28896       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
28897      &                UMO,PPCM,EPROJ,PPROJ
28898
28899       PARAMETER (NOPART=210)
28900       DIMENSION AVMULT(4,NOPART),AVE(4,NOPART),AVSWM(4,NOPART),
28901      &          AVPT(4,NOPART),IAVPT(4,NOPART)
28902       DATA ANAMEH /'DEUTERON','3-H     ','3-HE    ','4-HE    '/
28903
28904       GOTO (1,2,3) MODE
28905
28906 *------------------------------------------------------------------
28907 * initialization
28908     1 CONTINUE
28909       DO 10 I=1,NOPART
28910          DO 11 J=1,4
28911             AVMULT(J,I) = ZERO
28912             AVE(J,I)    = ZERO
28913             AVSWM(J,I)  = ZERO
28914             AVPT(J,I)   = ZERO
28915             IAVPT(J,I)  = 0
28916    11    CONTINUE
28917    10 CONTINUE
28918
28919       RETURN
28920
28921 *------------------------------------------------------------------
28922 * filling of histogram with event-record
28923     2 CONTINUE
28924       IF (PE.LT.0.0D0) THEN
28925          WRITE(LOUT,*) ' HIMULT:  PE < 0 ! ',PE
28926          RETURN
28927       ENDIF
28928       IF (.NOT.LFRAG) THEN
28929          IVEL = 2
28930          IF (LGREY)  IVEL = 3
28931          IF (LBLACK) IVEL = 4
28932          AVE(1,IDBJT)       = AVE(1,IDBJT)   +PE
28933          AVE(IVEL,IDBJT)    = AVE(IVEL,IDBJT)+PE
28934          AVPT(1,IDBJT)     = AVPT(1,IDBJT)   +PT
28935          AVPT(IVEL,IDBJT)  = AVPT(IVEL,IDBJT)+PT
28936          IAVPT(1,IDBJT)    = IAVPT(1,IDBJT)   +1
28937          IAVPT(IVEL,IDBJT) = IAVPT(IVEL,IDBJT)+1
28938          AVSWM(1,IDBJT)     = AVSWM(1,IDBJT)   +PE**SWMEXP
28939          AVSWM(IVEL,IDBJT)  = AVSWM(IVEL,IDBJT)+PE**SWMEXP
28940          AVMULT(1,IDBJT)    = AVMULT(1,IDBJT)   +ONE
28941          AVMULT(IVEL,IDBJT) = AVMULT(IVEL,IDBJT)+ONE
28942          IF (IDBJT.LT.116) THEN
28943 *   total energy, multiplicity
28944             AVE(1,30)       = AVE(1,30)   +PE
28945             AVE(IVEL,30)    = AVE(IVEL,30)+PE
28946             AVPT(1,30)     = AVPT(1,30)   +PT
28947             AVPT(IVEL,30)  = AVPT(IVEL,30)+PT
28948             IAVPT(1,30)    = IAVPT(1,30)   +1
28949             IAVPT(IVEL,30) = IAVPT(IVEL,30)+1
28950             AVSWM(1,30)     = AVSWM(1,30)+PE**SWMEXP
28951             AVSWM(IVEL,30)  = AVSWM(IVEL,30)+PE**SWMEXP
28952             AVMULT(1,30)    = AVMULT(1,30)   +ONE
28953             AVMULT(IVEL,30) = AVMULT(IVEL,30)+ONE
28954 *   charged energy, multiplicity
28955             IF (ICHAR.LT.0) THEN
28956                AVE(1,26)       = AVE(1,26)   +PE
28957                AVE(IVEL,26)    = AVE(IVEL,26)+PE
28958                AVPT(1,26)     = AVPT(1,26)   +PT
28959                AVPT(IVEL,26)  = AVPT(IVEL,26)+PT
28960                IAVPT(1,26)    = IAVPT(1,26)   +1
28961                IAVPT(IVEL,26) = IAVPT(IVEL,26)+1
28962                AVSWM(1,26)     = AVSWM(1,26)   +PE**SWMEXP
28963                AVSWM(IVEL,26)  = AVSWM(IVEL,26)+PE**SWMEXP
28964                AVMULT(1,26)    = AVMULT(1,26)   +ONE
28965                AVMULT(IVEL,26) = AVMULT(IVEL,26)+ONE
28966             ENDIF
28967             IF (ICHAR.NE.0) THEN
28968                AVE(1,27)       = AVE(1,27)   +PE
28969                AVE(IVEL,27)    = AVE(IVEL,27)+PE
28970                AVPT(1,27)     = AVPT(1,27)   +PT
28971                AVPT(IVEL,27)  = AVPT(IVEL,27)+PT
28972                IAVPT(1,27)    = IAVPT(1,27)   +1
28973                IAVPT(IVEL,27) = IAVPT(IVEL,27)+1
28974                AVSWM(1,27)     = AVSWM(1,27)   +PE**SWMEXP
28975                AVSWM(IVEL,27)  = AVSWM(IVEL,27)+PE**SWMEXP
28976                AVMULT(1,27)    = AVMULT(1,27)   +ONE
28977                AVMULT(IVEL,27) = AVMULT(IVEL,27)+ONE
28978             ENDIF
28979          ENDIF
28980       ENDIF
28981
28982       RETURN
28983
28984 *------------------------------------------------------------------
28985 * output
28986     3 CONTINUE
28987       WRITE(LOUT,3000)
28988  3000 FORMAT(/,1X,'HIMULT:',21X,'particle - statistics',/,
28989      &       29X,'---------------------',/)
28990       IF (MULDEF.EQ.1) THEN
28991          WRITE(LOUT,'(1X,A,/)') 'fast/grey/black: EMU-def.'
28992       ELSE
28993          BETGRE = 0.7D0
28994          BETBLC = 0.23D0
28995          WRITE(LOUT,3002) BETGRE,BETGRE,BETBLC,BETBLC
28996  3002    FORMAT(1X,'fast:  beta > ',F4.2,'    grey:  ',F4.2,' > beta > '
28997      &          ,F4.2,'    black:  beta < ',F4.2,/)
28998       ENDIF
28999       WRITE(LOUT,3003) SWMEXP
29000  3003 FORMAT(1X,'particle    |',12X,'average multiplicity',/,
29001      &      13X,'|     total         fast',
29002 C    &      '       grey     black      K      f(',F3.1,')',/,1X,
29003      &      '       grey     black    <pt>     f(',F3.1,')',/,1X,
29004      &      '------------+--------------',
29005      &      '-------------------------------------------------')
29006       DO 30 I=1,NOPART
29007          DO 31 J=1,4
29008             AVMULT(J,I) = AVMULT(J,I)/DBLE(MAX(ICEVT,1))
29009             AVE(J,I)    = AVE(J,I)/DBLE(MAX(ICEVT,1))/EPROJ
29010             AVPT(J,I)   = AVPT(J,I)/DBLE(MAX(IAVPT(J,I),1))
29011             AVSWM(J,I)  = AVSWM(J,I)/DBLE(MAX(ICEVT,1))/EPROJ**SWMEXP
29012    31    CONTINUE
29013          IF (I.LE.115) THEN
29014             WRITE(LOUT,3004) ANAME(I),I,
29015      &                       AVMULT(1,I),AVMULT(2,I),
29016      &                       AVMULT(3,I),AVMULT(4,I),
29017 C    &                       AVE(1,I),AVSWM(1,I)
29018      &                       AVPT(1,I),AVSWM(1,I)
29019          ELSEIF (I.LE.119) THEN
29020             WRITE(LOUT,3004) ANAMEH(I-115),I,
29021      &                       AVMULT(1,I),AVMULT(2,I),
29022      &                       AVMULT(3,I),AVMULT(4,I),
29023 C    &                       AVE(1,I),AVSWM(1,I)
29024      &                       AVPT(1,I),AVSWM(1,I)
29025          ENDIF
29026  3004    FORMAT(1X,A8,I4,'| ',2F13.6,2F9.5,2F9.5)
29027    30 CONTINUE
29028 **temporary
29029 C     WRITE(LOUT,'(A,F7.3)') ' number of charged heavy particles: ',
29030 C    &               AVMULT(3,27)+AVMULT(4,27)
29031 **
29032
29033       RETURN
29034       END
29035
29036 *$ CREATE DT_HISTAT.FOR
29037 *COPY DT_HISTAT
29038 *
29039 *===histat=============================================================*
29040 *
29041       SUBROUTINE DT_HISTAT(IDX,MODE)
29042
29043 ************************************************************************
29044 * This version dated 26.02.96 is written by S. Roesler                 *
29045 *                                                                      *
29046 * Last change 27.12.2006 by S. Roesler.                                *
29047 ************************************************************************
29048
29049       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
29050       SAVE
29051
29052       PARAMETER ( LINP = 10 ,
29053      &            LOUT = 6 ,
29054      &            LDAT = 9 )
29055
29056       PARAMETER (ZERO=0.0D0,ONE=1.0D0,TWO=2.0D0,TINY14=1.0D-14)
29057       PARAMETER (NDIM=199)
29058
29059 * event history
29060
29061       PARAMETER (NMXHKK=200000)
29062
29063       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
29064      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
29065      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
29066
29067 * extended event history
29068       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
29069      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
29070      &                IHIST(2,NMXHKK)
29071
29072 * particle properties (BAMJET index convention)
29073       CHARACTER*8  ANAME
29074       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
29075      &                IICH(210),IIBAR(210),K1(210),K2(210)
29076
29077       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
29078
29079 * Glauber formalism: cross sections
29080       COMMON /DTGLXS/ ECMNN(NEB),Q2G(NQB),ECMNOW,Q2,
29081      &                XSTOT(NEB,NQB,NCOMPX),XSELA(NEB,NQB,NCOMPX),
29082      &                XSQEP(NEB,NQB,NCOMPX),XSQET(NEB,NQB,NCOMPX),
29083      &                XSQE2(NEB,NQB,NCOMPX),XSPRO(NEB,NQB,NCOMPX),
29084      &                XSDEL(NEB,NQB,NCOMPX),XSDQE(NEB,NQB,NCOMPX),
29085      &                XETOT(NEB,NQB,NCOMPX),XEELA(NEB,NQB,NCOMPX),
29086      &                XEQEP(NEB,NQB,NCOMPX),XEQET(NEB,NQB,NCOMPX),
29087      &                XEQE2(NEB,NQB,NCOMPX),XEPRO(NEB,NQB,NCOMPX),
29088      &                XEDEL(NEB,NQB,NCOMPX),XEDQE(NEB,NQB,NCOMPX),
29089      &                BSLOPE,NEBINI,NQBINI
29090
29091 * emulsion treatment
29092       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
29093      &                NCOMPO,IEMUL
29094
29095 * properties of interacting particles
29096       COMMON /DTPRTA/ IT,ITZ,IP,IPZ,IJPROJ,IBPROJ,IJTARG,IBTARG
29097
29098 * rejection counter
29099       COMMON /DTREJC/ IRPT,IRHHA,IRRES(2),LOMRES,LOBRES,
29100      &                IRCHKI(2),IRFRAG,IRCRON(3),IREVT,
29101      &                IREXCI(3),IRDIFF(2),IRINC
29102
29103 * statistics: residual nuclei
29104       COMMON /DTSTA2/ EXCDPM(4),EXCEVA(2),
29105      &                NINCGE,NINCCO(2,3),NINCHR(2,2),NINCWO(2),
29106      &                NINCST(2,4),NINCEV(2),
29107      &                NRESTO(2),NRESPR(2),NRESNU(2),NRESBA(2),
29108      &                NRESPB(2),NRESCH(2),NRESEV(4),
29109      &                NEVA(2,6),NEVAGA(2),NEVAHT(2),NEVAHY(2,2,240),
29110      &                NEVAFI(2,2)
29111
29112 * parameter for intranuclear cascade
29113       LOGICAL LPAULI
29114       COMMON /DTFOTI/ TAUFOR,KTAUGE,ITAUVE,INCMOD,LPAULI
29115
29116 *      INCLUDE '(DIMPAR)'
29117 *     Taken from FLUKA
29118       PARAMETER ( MXXRGN =20000 )
29119       PARAMETER ( MXXMDF =  710 )
29120       PARAMETER ( MXXMDE =  702 )
29121       PARAMETER ( MFSTCK =40000 )
29122       PARAMETER ( MESTCK =  100 )
29123       PARAMETER ( MOSTCK = 2000 )
29124       PARAMETER ( MXPRSN =  100 )
29125       PARAMETER ( MXPDPM =  800 )
29126       PARAMETER ( MXPSCS =30000 )
29127       PARAMETER ( MXGLWN =  300 )
29128       PARAMETER ( MXOUTU =   50 )
29129       PARAMETER ( NALLWP =   64 )
29130       PARAMETER ( NELEMX =   80 )
29131       PARAMETER ( MPDPDX =   18 )
29132       PARAMETER ( MXHTTR =  260 )
29133       PARAMETER ( MXSEAX =   20 )
29134       PARAMETER ( MXHTNC = MXSEAX + 1 )
29135       PARAMETER ( ICOMAX = 2400 )
29136       PARAMETER ( ICHMAX = ICOMAX + MXXMDF )
29137       PARAMETER ( NSTBIS =  304 )
29138       PARAMETER ( NQSTIS =   46 )
29139       PARAMETER ( NTSTIS = NSTBIS + NQSTIS )
29140       PARAMETER ( MXPABL =  120 )
29141       PARAMETER ( IDMAXP =  450 )
29142       PARAMETER ( IDMXDC = 2000 )
29143       PARAMETER ( MXMCIN =  410 )
29144       PARAMETER ( IHYPMX =    4 )
29145       PARAMETER ( MKBMX1 =   11 )
29146       PARAMETER ( MKBMX2 =   11 )
29147       PARAMETER ( MXIRRD = 2500 )
29148       PARAMETER ( MXTRDC = 1500 )
29149       PARAMETER ( NKTL   =   17 )
29150       PARAMETER ( NBLNMX = 40000000 )
29151
29152 *      INCLUDE '(PAREVT)'
29153 *     Taken from FLUKA
29154       PARAMETER ( FRDIFF = 0.2D+00 )
29155       PARAMETER ( ETHSEA = 1.0D+00 )
29156 *
29157       LOGICAL LDIFFR, LINCTV, LEVPRT, LHEAVY, LDEEXG, LGDHPR, LPREEX,
29158      &        LHLFIX, LPRFIX, LPARWV, LPOWER, LSNGCH, LSCHDF, LHADRI,
29159      &        LNUCRI, LPEANU, LPHDRC, LATMSS, LISMRS, LCHDCY, LCHDCR,
29160      &        LMLCCR, LRVKIN, LVP2XX, LV2XNW, LNWV2X, LEVFIN
29161       COMMON / PAREVT / DPOWER, FSPRD0, FSHPFN, RN1GSC, RN2GSC, RNSWTC,
29162      &                  LDIFFR (NALLWP),LPOWER, LINCTV, LEVPRT, LHEAVY,
29163      &                  LDEEXG, LGDHPR, LPREEX, LHLFIX, LPRFIX, LPARWV,
29164      &                  LSNGCH, LSCHDF, LHADRI, LNUCRI, LPEANU, LPHDRC,
29165      &                  LATMSS, LISMRS, LCHDCY, LCHDCR, LMLCCR, LRVKIN,
29166      &                  LVP2XX, LV2XNW, LNWV2X, LEVFIN
29167
29168 *      INCLUDE '(FRBKCM)'
29169 *     Taken from FLUKA
29170 *  Maximum number of fragments to be emitted:
29171       PARAMETER ( MXFFBK =     6 )
29172       PARAMETER ( MXZFBK =    10 )
29173       PARAMETER ( MXNFBK =    12 )
29174       PARAMETER ( MXAFBK =    16 )
29175       PARAMETER ( MXASST =    25 )
29176       PARAMETER ( NXAFBK = MXAFBK + 1 )
29177       PARAMETER ( NXZFBK = MXZFBK + MXFFBK / 3 + MXASST - NXAFBK )
29178       PARAMETER ( NXNFBK = MXNFBK + MXFFBK / 3 + MXASST - NXAFBK )
29179       PARAMETER ( MXPSST =   700 )
29180 *  Maximum number of pre-computed break-up combinations
29181       PARAMETER ( MXPPFB = 42500 )
29182 *  Maximum number of break-up combinations, including special
29183 *  run-time ones:
29184       PARAMETER ( MXPSFB = 43000 )
29185 *  Base for J multiplicity encoding:
29186       PARAMETER ( IBFRBK =    73 )
29187 *  Maximum Ibfrbk exponent to avoid overflow of I*4(roughly at 2.1x10^9)
29188 *  it must be (Ibfrbk-1) + (Ibfrbk-1)*Ibfrbk + (Ibfrbk-1)*Ibfrbk^2 + ...
29189 *  ... + (Ibfrbk-1)*Ibfrbk^Jpwfbx < 2100000000,
29190 *  --> Ibfrbk^(Jpwfbx+1) < 2100000000
29191       PARAMETER ( JPWFBX =     4 )
29192       LOGICAL LFRMBK, LNCMSS
29193       COMMON / FRBKCM /  AMUFBK, EEXFBK (MXPSST), AMFRBK (MXPSST),
29194      &          WEIFBK (MXPSST), GAMFBK (MXPSST), EXFRBK (MXPSFB),
29195      &          SDMFBK (MXPSFB), COUFBK (MXPSFB), CENFBK (MXPSFB),
29196      &          EXMXFB, R0FRBK, R0CFBK, C1CFBK, C2CFBK, FRBKLS,
29197      &          IFRBKN (MXPSST), IFRBKZ (MXPSST),
29198      &          IFBKSP (MXPSST), IFBKPR (MXPSST), IFBKST (MXPSST),
29199      &          IPSIND (0:NXNFBK,0:NXZFBK,2), JPSIND (0:MXASST),
29200      &          IFBIND (0:NXNFBK,0:NXZFBK,2), JFBIND (0:NXAFBK),
29201      &          IFBCHA (9,MXPSFB), IPOSST, IPOSFB, IFBSTF, IFBPSF,
29202      &          IFBFRB, IFBCHN, IFBNC1, IFBNC2, NBUFBK, LFRMBK, LNCMSS
29203
29204 *      INCLUDE '(EVAFLG)'
29205 *     Taken from FLUKA
29206       LOGICAL LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29207      &        LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29208      &        LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29209      &        LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29210       COMMON / EVAFLG /     BRPNFR (0:2), EBRPFR (0:2), EMVBRP (0:2),
29211      &        ILVMOD, JLVMOD, JSIPFL, IMSSFR, JMSSFR, IEVFSS, MXAHEV,
29212      &        MXZHEV, IFHVFL, IFKYMX, IGMCMP, MPMODE, MSMODE, MUMODE,
29213      &        MFMODE, MEMODE, MRMODE, ITMCRR, IASYCR, IFSBCR, IFSSBR,
29214      &        LOLDEV, LUFULL, LNWLOW, LASMEN, LGMCMP, LGDRFT, LDSCLV,
29215      &        LDSCGM, LNDSLD, LMNJPR, LBRPEN, LNWBRP, LIFKEY, LOLDSM,
29216      &        LNAIPR, LGUSPR, LFLKCO, LLVMOD, LHVEVP, LHVECN, LHVCAL,
29217      &        LHVRAL, LHVSGF, LTMCRR, LBZZCR, LQCSKP
29218
29219 * temporary storage for one final state particle
29220       LOGICAL LFRAG,LGREY,LBLACK
29221       COMMON /DTFSPA/ AMASS,PE,EECMS,PX,PY,PZ,PZCMS,PT,PTOT,ET,EKIN,
29222      &                SINTHE,COSTHE,THETA,THECMS,
29223      &                BETA,YY,YYCMS,ETA,ETACMS,XLAB,XF,
29224      &                IST,IDPDG,IDBJT,IBARY,ICHAR,MULDEF,
29225      &                LFRAG,LGREY,LBLACK
29226
29227 * event flag used for histograms
29228       COMMON /DTNORM/ ICEVT,IEVHKK
29229
29230 * statistics: double-Pomeron exchange
29231       COMMON /DTFLG2/ INTFLG,IPOPO
29232
29233       DIMENSION EMUSAM(NCOMPX)
29234
29235       CHARACTER*13 CMSG(3)
29236       DATA CMSG /'not requested','not requested','not requested'/
29237
29238       GOTO (1,2,3,4,5) MODE
29239
29240 *------------------------------------------------------------------
29241 * initialization
29242     1 CONTINUE
29243 *  emulsion treatment
29244       IF (NCOMPO.GT.0) THEN
29245          DO 10 I=1,NCOMPX
29246             EMUSAM(I) = ZERO
29247    10    CONTINUE
29248       ENDIF
29249 * common /DTSTA2/, statistics on i.n.c., residual nuclei, evap.
29250       NINCGE = 0
29251       DO 11 I=1,2
29252          EXCDPM(I)   = ZERO
29253          EXCDPM(I+2) = ZERO
29254          EXCEVA(I)   = ZERO
29255          NINCWO(I)   = 0
29256          NINCEV(I)   = 0
29257          NRESTO(I)   = 0
29258          NRESPR(I)   = 0
29259          NRESNU(I)   = 0
29260          NRESBA(I)   = 0
29261          NRESPB(I)   = 0
29262          NRESCH(I)   = 0
29263          NRESEV(I)   = 0
29264          NRESEV(I+2) = 0
29265          NEVAGA(I)   = 0
29266          NEVAHT(I)   = 0
29267          NEVAFI(1,I) = 0
29268          NEVAFI(2,I) = 0
29269          DO 12 J=1,6
29270             IF (J.LE.2) NINCHR(I,J) = 0
29271             IF (J.LE.3) NINCCO(I,J) = 0
29272             IF (J.LE.4) NINCST(I,J) = 0
29273             NEVA(I,J) = 0
29274    12    CONTINUE
29275          DO 13 J=1,210
29276             NEVAHY(1,I,J) = 0
29277             NEVAHY(2,I,J) = 0
29278    13    CONTINUE
29279    11 CONTINUE
29280       MAXGEN = 0
29281 **dble Po statistics.
29282       KPOPO = 0
29283
29284       RETURN
29285 *------------------------------------------------------------------
29286 * filling of histogram with event-record
29287     2 CONTINUE
29288       IF (IST.EQ.-1) THEN
29289          IF (.NOT.LFRAG) THEN
29290             IF (IDPDG.EQ.2212) THEN
29291                NEVA(NOBAM(IDX),1) = NEVA(NOBAM(IDX),1)+1
29292             ELSEIF (IDPDG.EQ.2112) THEN
29293                NEVA(NOBAM(IDX),2) = NEVA(NOBAM(IDX),2)+1
29294             ELSEIF (IDPDG.EQ.22) THEN
29295                NEVAGA(NOBAM(IDX)) = NEVAGA(NOBAM(IDX))+1
29296             ELSEIF (IDPDG.EQ.80000) THEN
29297                IF (IDBJT.EQ.116) THEN
29298                   NEVA(NOBAM(IDX),3) = NEVA(NOBAM(IDX),3)+1
29299                ELSEIF (IDBJT.EQ.117) THEN
29300                   NEVA(NOBAM(IDX),4) = NEVA(NOBAM(IDX),4)+1
29301                ELSEIF (IDBJT.EQ.118) THEN
29302                   NEVA(NOBAM(IDX),5) = NEVA(NOBAM(IDX),5)+1
29303                ELSEIF (IDBJT.EQ.119) THEN
29304                   NEVA(NOBAM(IDX),6) = NEVA(NOBAM(IDX),6)+1
29305                ENDIF
29306             ENDIF
29307          ELSE
29308 *   heavy fragments (here: fission products only)
29309             NEVAHY(NOBAM(IDX),1,IBARY) = NEVAHY(NOBAM(IDX),1,IBARY)+1
29310             NEVAHY(NOBAM(IDX),2,ICHAR) = NEVAHY(NOBAM(IDX),2,ICHAR)+1
29311             NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29312          ENDIF
29313       ELSEIF ((IST.EQ.1).AND.(.NOT.LFRAG)) THEN
29314          IF (IDCH(IDX).GT.MAXGEN) MAXGEN = IDCH(IDX)
29315       ENDIF
29316
29317       RETURN
29318 *------------------------------------------------------------------
29319 * output
29320     3 CONTINUE
29321
29322 **dble Po statistics.
29323 C     WRITE(LOUT,'(1X,A,2I7,2E12.4)')
29324 C    &   '# evts. / # dble-Po. evts / s_in / s_popo :',
29325 C    & ICEVT,KPOPO,XSPRO(1,1,1),XSPRO(1,1,1)*DBLE(KPOPO)/DBLE(ICEVT)
29326
29327 *  emulsion treatment
29328       IF (NCOMPO.GT.0) THEN
29329          WRITE(LOUT,3000)
29330  3000    FORMAT(/,1X,'HISTAT:',14X,'statistics - target emulsion',/,
29331      &          22X,'----------------------------',/,/,19X,
29332      &          'mass    charge          fraction',/,39X,
29333      &          'input     treated',/)
29334          DO 30 I=1,NCOMPO
29335             WRITE(LOUT,3013) I,IEMUMA(I),IEMUCH(I),EMUFRA(I),
29336      &                       EMUSAM(I)/DBLE(ICEVT)
29337  3013       FORMAT(12X,I2,1X,2I8,6X,F7.3,5X,F7.3)
29338    30    CONTINUE
29339       ENDIF
29340
29341 *  i.n.c. statistics: output
29342       WRITE(LOUT,3001) ICEVT,NRESEV(2),IRINC
29343  3001 FORMAT(/,1X,'HISTAT:',14X,'statistics - intranuclear cascade',/,
29344      &       22X,'---------------------------------',/,/,1X,
29345      &       'no. of events for normalization: (accepted final events,',
29346      &       ' evt)',4X,I6,/,34X,'(events before evap.-step, evt1)',I6,
29347      &       /,1X,'no. of rejected events due to intranuclear',
29348      &       ' cascade',15X,I6,/)
29349       ICEV  = MAX(ICEVT,1)
29350       ICEV1 = ICEV
29351       IF (LEVPRT) ICEV1 = MAX(NRESEV(2),1)
29352       WRITE(LOUT,3002)
29353      &     (DBLE(NINCWO(I))/DBLE(ICEV),I=1,2),
29354      &     ((DBLE(NINCST(I,J))/DBLE(ICEV),I=1,2),J=1,4),
29355      &     KTAUGE,DBLE(NINCGE)/DBLE(ICEV),
29356      &    (DBLE(NINCCO(I,1)+NINCCO(I,2)+NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29357      &     (DBLE(NINCCO(I,2))/DBLE(ICEV1),I=1,2),
29358      &     (DBLE(NINCCO(I,3))/DBLE(ICEV1),I=1,2),
29359      &     (DBLE(NINCCO(I,1))/DBLE(ICEV1),I=1,2)
29360  3002 FORMAT(1X,'no. of wounded nucl. in proj./ target (mean per evt)',
29361      &       5X,F6.2,' /',F6.2,/,1X,'no. of particles unable to escape',
29362      &       ' proj./ target (mean per evt)',/,8X,'baryons:  pos. ',
29363      &       F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,/,8X,
29364      &       'mesons:   pos. ',F7.3,' /',F7.3,'   neg. ',F7.3,' /',F7.3,
29365      &       /,1X,'maximum no. of generations treated (maximum allowed:'
29366      &       ,I4,')',/,43X,'(mean per evt)',5X,F6.2,/,1X,'no. of sec.',
29367      &       ' interactions in proj./ target (mean per evt1)',
29368      &       F7.3,' /',F7.3,/,8X,'out of which by inelastic',
29369      &       ' interactions',12X,F7.3,' /',F7.3,/,21X,'by elastic ',
29370      &       'interactions',14X,F7.3,' /',F7.3,/,21X,'by absorption ',
29371      &       '(ap, K-, pi- only)     ',F7.3,' /',F7.3,/)
29372       WRITE(LOUT,3003) NRESEV(2),NRESEV(4),IREXCI,
29373      &                 IREXCI(1)+IREXCI(2)+IREXCI(3)
29374  3003 FORMAT(/,1X,'HISTAT:',14X,'statistics - residual nuclei, ',
29375      &       'evaporation',/,22X,'-----------------------------',
29376      &       '------------',/,/,1X,'no. of events for normal.: ',
29377      &       '(events handled by FICONF, evt)',7X,I6,/,28X,'(events',
29378      &       ' passing the evap.-step, evt1) ',I6,/,1X,'no. of',
29379      &       ' rejected events     (',I4,',',I4,',',I4,')',22X,I6,/)
29380
29381       WRITE(LOUT,3004)
29382  3004 FORMAT(/,22X,'1) before evaporation-step:',/)
29383       ICEV  = MAX(NRESEV(2),1)
29384       WRITE(LOUT,3005)
29385      &     (DBLE(NRESTO(I))/DBLE(ICEV),I=1,2),
29386      &     (DBLE(NRESPR(I))/DBLE(ICEV),I=1,2),
29387      &     (DBLE(NRESNU(I))/DBLE(ICEV),I=1,2),
29388      &     (DBLE(NRESBA(I))/DBLE(ICEV),I=1,2),
29389      &     (DBLE(NRESPB(I))/DBLE(ICEV),I=1,2),
29390      &     (DBLE(NRESCH(I))/DBLE(ICEV),I=1,2),
29391      &     (EXCDPM(I)/DBLE(ICEV),I=1,2),
29392      &     (EXCDPM(I+2)/DBLE(ICEV),I=1,2)
29393  3005    FORMAT(1X,'residual nuclei:  (mean values per evt)',12X,
29394      &       'proj. / target',/,/,8X,'total number of particles',15X,
29395      &       2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29396      &       'neutrons',18X,2F9.3,/,22X,'baryons',19X,2F9.3,/,22X,
29397      &       'pos. baryons',14X,2F9.3,/,8X,'total charge',28X,2F9.3,/,
29398      &       /,8X,'excitation energy (bef. evap.-step)   ',2E11.3,/,
29399      &       8X,'excitation energy per nucleon         ',2E11.3,/,/)
29400
29401 * evaporation / fission / fragmentation statistics: output
29402       ICEV  = MAX(NRESEV(2),1)
29403       ICEV1 = MAX(NRESEV(4),1)
29404       NTEVA1 =
29405      &   NEVA(1,1)+NEVA(1,2)+NEVA(1,3)+NEVA(1,4)+NEVA(1,5)+NEVA(1,6)
29406       NTEVA2 =
29407      &   NEVA(2,1)+NEVA(2,2)+NEVA(2,3)+NEVA(2,4)+NEVA(2,5)+NEVA(2,6)
29408       IF (LEVPRT) THEN
29409
29410          IF (IEVFSS.EQ.1) CMSG(1) = 'requested    '
29411
29412          IF (LFRMBK)     CMSG(2) = 'requested    '
29413          IF (LDEEXG)     CMSG(3) = 'requested    '
29414          WRITE(LOUT,3006)
29415      &        CMSG,
29416      &        DBLE(NTEVA1)/DBLE(ICEV1),DBLE(NTEVA2)/DBLE(ICEV1),
29417      &        (DBLE(NEVA(I,1))/DBLE(ICEV1),I=1,2),
29418      &        (DBLE(NEVA(I,2))/DBLE(ICEV1),I=1,2),
29419      &        (DBLE(NEVA(I,3))/DBLE(ICEV1),I=1,2),
29420      &        (DBLE(NEVA(I,4))/DBLE(ICEV1),I=1,2),
29421      &        (DBLE(NEVA(I,5))/DBLE(ICEV1),I=1,2),
29422      &        (DBLE(NEVA(I,6))/DBLE(ICEV1),I=1,2),
29423      &        (DBLE(NEVAGA(I))/DBLE(ICEV1),I=1,2),
29424      &        (DBLE(NEVAHT(I))/DBLE(ICEV1),I=1,2)
29425  3006    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,'Fission:',
29426      &       13X,A13,/,1X,'Fermi-Break-up:',6X,A13,/,1X,'Gamma-',
29427      &       'deexcitation:',2X,A13,/,/,
29428      &       1X,'evaporation/deexcitation:  (mean values per evt1)  ',
29429      &       'proj. / target',/,/,8X,'total number of evap. particles',
29430      &       9X,2F9.3,/,8X,'out of which: protons',19X,2F9.3,/,22X,
29431      &       'neutrons',18X,2F9.3,/,22X,'deuterons',17X,2F9.3,/,22X,
29432      &       '3-H',23X,2F9.3,/,22X,'3-He',22X,2F9.3,/,22X,'4-He',22X,
29433      &       2F9.3,/,8X,'nucl. deexcit. gammas',19X,2F9.3,/,8X,
29434      &       'heavy fragments',25X,2F9.3,/)
29435
29436          IF (IEVFSS.EQ.1) THEN
29437
29438             WRITE(LOUT,3007) NEVAFI(1,1),NEVAFI(1,2),
29439      &                       NEVAFI(2,1),NEVAFI(2,2),
29440      &             DBLE(NEVAFI(2,1))/DBLE(MAX(NEVAFI(1,1),1))*100.0D0,
29441      &             DBLE(NEVAFI(2,2))/DBLE(MAX(NEVAFI(1,2),1))*100.0D0
29442  3007       FORMAT(1X,'Fission:   total number of events',14X,2I9,/
29443      &             12X,'out of which fission occured',8X,2I9,/,
29444      &             50X,'(',F5.2,'%) (',F5.2,'%)',/)
29445          ENDIF
29446
29447 C        IF ((LFRMBK).OR.(IEVFSS.EQ.1)) THEN
29448
29449 C           WRITE(LOUT,3008)
29450 C3008       FORMAT(1X,'heavy fragments - statistics:',7X,'charge',
29451 C    &             '       proj.   / target',/)
29452 C           DO 31 I=1,210
29453 C              IF ((NEVAHY(1,2,I).NE.0).OR.(NEVAHY(2,2,I).NE.0)) THEN
29454 C                 WRITE(LOUT,3009) I,
29455 C    &            (DBLE(NEVAHY(K,2,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29456 C3009             FORMAT(38X,I3,3X,2E12.3)
29457 C              ENDIF
29458 C  31       CONTINUE
29459 C           WRITE(LOUT,3010)
29460 C3010       FORMAT(1X,'heavy fragments - statistics:',7X,'mass  ',
29461 C    &             '       proj.   / target',/)
29462 C           DO 32 I=1,210
29463 C              IF ((NEVAHY(1,1,I).NE.0).OR.(NEVAHY(2,1,I).NE.0)) THEN
29464 C                 WRITE(LOUT,3011) I,
29465 C    &            (DBLE(NEVAHY(K,1,I))*XSPRO(1,1,1)/DBLE(ICEV1),K=1,2)
29466 C3011             FORMAT(38X,I3,3X,2E12.3)
29467 C              ENDIF
29468 C  32       CONTINUE
29469 C           WRITE(LOUT,*)
29470 C        ENDIF
29471       ELSE
29472          WRITE(LOUT,3012)
29473  3012    FORMAT(22X,'2) after  evaporation-step:',/,/,1X,
29474      &       'Evaporation:         not requested',/)
29475       ENDIF
29476
29477       RETURN
29478 *------------------------------------------------------------------
29479 * filling of histogram with event-record
29480     4 CONTINUE
29481 *  emulsion treatment
29482       IF (NCOMPO.GT.0) THEN
29483          DO 40 I=1,NCOMPO
29484             IF (IT.EQ.IEMUMA(I)) THEN
29485                EMUSAM(I) = EMUSAM(I)+ONE
29486             ENDIF
29487    40    CONTINUE
29488       ENDIF
29489       NINCGE = NINCGE+MAXGEN
29490       MAXGEN = 0
29491 **dble Po statistics.
29492       IF (IPOPO.EQ.1) KPOPO = KPOPO+1
29493
29494       RETURN
29495 *------------------------------------------------------------------
29496 * filling of histogram with event-record
29497     5 CONTINUE
29498       IF ((ISTHKK(IDX).EQ.15).OR.(ISTHKK(IDX).EQ.16)) THEN
29499          IB = IIBAR(IDBAM(IDX))
29500          IC = IICH(IDBAM(IDX))
29501          J  = ISTHKK(IDX)-14
29502          IF ( ((ABS(IB).EQ.1).AND.(IC.EQ.1)).OR.(IC.EQ.0) ) THEN
29503             NINCST(J,1) = NINCST(J,1)+1
29504          ELSEIF ((ABS(IB).EQ.1).AND.(IC.EQ.-1)) THEN
29505             NINCST(J,2) = NINCST(J,2)+1
29506          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ. 1)) THEN
29507             NINCST(J,3) = NINCST(J,3)+1
29508          ELSEIF ((ABS(IB).EQ.0).AND.(IC.EQ.-1)) THEN
29509             NINCST(J,4) = NINCST(J,4)+1
29510          ENDIF
29511       ELSEIF (ISTHKK(IDX).EQ.17) THEN
29512          NINCWO(1) = NINCWO(1)+1
29513       ELSEIF (ISTHKK(IDX).EQ.18) THEN
29514          NINCWO(2) = NINCWO(2)+1
29515       ELSEIF (ISTHKK(IDX).EQ.1001) THEN
29516          IB = IDRES(IDX)
29517          IC = IDXRES(IDX)
29518          IF (IC.GT.0) THEN
29519             NEVAHY(NOBAM(IDX),1,IB) = NEVAHY(NOBAM(IDX),1,IB)+1
29520             NEVAHY(NOBAM(IDX),2,IC) = NEVAHY(NOBAM(IDX),2,IC)+1
29521          ENDIF
29522          NEVAHT(NOBAM(IDX)) = NEVAHT(NOBAM(IDX))+1
29523       ENDIF
29524
29525       RETURN
29526       END
29527 *$ CREATE DT_NEWHGR.FOR
29528 *COPY DT_NEWHGR
29529 *
29530 *===newhgr=============================================================*
29531 *
29532       SUBROUTINE DT_NEWHGR(XLIM1,XLIM2,XLIM3,XLIMB,IBIN,IREFN)
29533
29534 ************************************************************************
29535 *                                                                      *
29536 *     Histogram initialization.                                        *
29537 *                                                                      *
29538 *     input:  XLIM1/XLIM2  lower/upper edge of histogram-window        *
29539 *             XLIM3        bin size                                    *
29540 *             IBIN    > 0  number of bins in equidistant lin. binning  *
29541 *                     = -1 reset histograms                            *
29542 *                     < -1 |IBIN| number of bins in equidistant log.   *
29543 *                          binning or log. binning in user def. struc. *
29544 *             XLIMB(*)     user defined bin structure                  *
29545 *                                                                      *
29546 *     The bin structure is sensitive to                                *
29547 *             XLIM1, XLIM3, IBIN     if     XLIM3 > 0   (lin.)         *
29548 *             XLIM1, XLIM2, IBIN     if     XLIM3 = 0   (lin. & log.)  *
29549 *             XLIMB, IBIN            if     XLIM3 < 0                  *
29550 *                                                                      *
29551 *                                                                      *
29552 *     output: IREFN        histogram index                             *
29553 *                          (= -1 for inconsistent histogr. request)    *
29554 *                                                                      *
29555 * This subroutine is based on a original version by R. Engel.          *
29556 * This version dated 22.4.95 is written  by S. Roesler.                *
29557 ************************************************************************
29558
29559       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29560       SAVE
29561
29562       PARAMETER ( LINP = 10 ,
29563      &            LOUT = 6 ,
29564      &            LDAT = 9 )
29565
29566       LOGICAL LSTART
29567
29568       PARAMETER (ZERO   =  0.0D0,
29569      &           TINY   =  1.0D-10)
29570
29571       DIMENSION XLIMB(*)
29572
29573 * histograms
29574
29575       PARAMETER (NHIS=150, NDIM=250)
29576
29577       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29578      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29579
29580 * auxiliary common for histograms
29581       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29582
29583       DATA LSTART /.TRUE./
29584
29585 * reset histogram counter
29586       IF (LSTART.OR.(IBIN.EQ.-1)) THEN
29587          IHISL  = 0
29588          IF (IBIN.EQ.-1) RETURN
29589          LSTART = .FALSE.
29590       ENDIF
29591
29592       IHIS  = IHISL+1
29593 * check for maximum number of allowed histograms
29594       IF (IHIS.GT.NHIS) THEN
29595          WRITE(LOUT,1003) IHIS,NHIS,IHIS
29596  1003    FORMAT(1X,'NEWHGR:   warning!  number of histograms (',
29597      &          I4,') exceeds array size (',I4,')',/,21X,
29598      &          'histogram',I3,' skipped!')
29599          GOTO 9999
29600       ENDIF
29601
29602       IREFN = IHIS
29603       IBINS(IHIS) = ABS(IBIN)
29604 * check requested number of bins
29605       IF (IBINS(IHIS).GE.NDIM) THEN
29606          WRITE(LOUT,1000) IBIN,NDIM,NDIM
29607  1000    FORMAT(1X,'NEWHGR:   warning!  number of bins (',
29608      &          I3,') exceeds array size (',I3,')',/,21X,
29609      &          'and will be reset to ',I3)
29610          IBINS(IHIS) = NDIM
29611       ENDIF
29612       IF (IBINS(IHIS).EQ.0) THEN
29613          WRITE(LOUT,1001) IBIN,IHIS
29614  1001    FORMAT(1X,'NEWHGR:   warning!  inconsistent number of',
29615      &          ' bins (',I3,')',/,21X,'histogram',I3,' skipped!')
29616          GOTO 9999
29617       ENDIF
29618
29619 * initialize arrays
29620       DO 1 I=1,NDIM
29621          DO 2 K=1,3
29622             HIST(K,IHIS,I)   = ZERO
29623             HIST(K+3,IHIS,I) = ZERO
29624             TMPHIS(K,IHIS,I) = ZERO
29625     2    CONTINUE
29626          HIST(7,IHIS,I)   = ZERO
29627     1 CONTINUE
29628       DENTRY(1,IHIS)= ZERO
29629       DENTRY(2,IHIS)= ZERO
29630       OVERF(IHIS)   = ZERO
29631       UNDERF(IHIS)  = ZERO
29632       TMPUFL(IHIS)  = ZERO
29633       TMPOFL(IHIS)  = ZERO
29634
29635 * bin str. sensitive to lower edge, bin size, and numb. of bins
29636       IF (XLIM3.GT.ZERO) THEN
29637          DO 3 K=1,IBINS(IHIS)+1
29638             HIST(1,IHIS,K) = XLIM1+DBLE(K-1)*XLIM3
29639     3    CONTINUE
29640          ISWI(IHIS) = 1
29641 * bin str. sensitive to lower/upper edge and numb. of bins
29642       ELSEIF (XLIM3.EQ.ZERO) THEN
29643 *   linear binning
29644          IF (IBIN.GT.0) THEN
29645             XLOW = XLIM1
29646             XHI  = XLIM2
29647             IF (XLIM2.LE.XLIM1) THEN
29648                WRITE(LOUT,1002) XLIM1,XLIM2
29649  1002          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29650      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29651                GOTO 9999
29652             ENDIF
29653             ISWI(IHIS) = 1
29654          ELSEIF (IBIN.LT.-1) THEN
29655 *   logarithmic binning
29656             IF ((XLIM1.LE.ZERO).OR.(XLIM2.LE.ZERO)) THEN
29657                WRITE(LOUT,1004) XLIM1,XLIM2
29658  1004          FORMAT(1X,'NEWHGR:   warning!  inconsistent log. ',
29659      &                'binning',/,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29660                GOTO 9999
29661             ENDIF
29662             IF (XLIM2.LE.XLIM1) THEN
29663                WRITE(LOUT,1005) XLIM1,XLIM2
29664  1005          FORMAT(1X,'NEWHGR:   warning!  inconsistent x-range',
29665      &                /,21X,'(XLIM1,XLIM2 = ',2E11.4,')')
29666                GOTO 9999
29667             ENDIF
29668             XLOW = LOG10(XLIM1)
29669             XHI  = LOG10(XLIM2)
29670             ISWI(IHIS) = 3
29671          ENDIF
29672          DX = ABS(XHI-XLOW)/DBLE(MAX(IBINS(IHIS),1))
29673          DO 4 K=1,IBINS(IHIS)+1
29674             HIST(1,IHIS,K) = XLOW+DBLE(K-1)*DX
29675     4    CONTINUE
29676       ELSE
29677 * user defined bin structure
29678          DO 5 K=1,IBINS(IHIS)+1
29679             IF (IBIN.GT.0) THEN
29680                HIST(1,IHIS,K) = XLIMB(K)
29681                ISWI(IHIS) = 2
29682             ELSEIF (IBIN.LT.-1) THEN
29683                HIST(1,IHIS,K) = LOG10(XLIMB(K))
29684                ISWI(IHIS) = 4
29685             ENDIF
29686     5    CONTINUE
29687       ENDIF
29688
29689 * histogram accepted
29690       IHISL = IHIS
29691
29692       RETURN
29693
29694  9999 CONTINUE
29695       IREFN = -1
29696       RETURN
29697       END
29698
29699 *$ CREATE DT_FILHGR.FOR
29700 *COPY DT_FILHGR
29701 *
29702 *===filhgr=============================================================*
29703 *
29704       SUBROUTINE DT_FILHGR(XI,YI,IHIS,NEVT)
29705
29706 ************************************************************************
29707 *                                                                      *
29708 *     Scoring for histogram IHIS.                                      *
29709 *                                                                      *
29710 * This subroutine is based on a original version by R. Engel.          *
29711 * This version dated 23.4.95 is written  by S. Roesler.                *
29712 ************************************************************************
29713
29714       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29715       SAVE
29716
29717       PARAMETER ( LINP = 10 ,
29718      &            LOUT = 6 ,
29719      &            LDAT = 9 )
29720
29721       PARAMETER (ZERO = 0.0D0,
29722      &           ONE  = 1.0D0,
29723      &           TINY = 1.0D-10)
29724
29725 * histograms
29726
29727       PARAMETER (NHIS=150, NDIM=250)
29728
29729       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29730      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29731
29732 * auxiliary common for histograms
29733       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29734
29735       DATA NCEVT /1/
29736
29737       X = XI
29738       Y = YI
29739
29740 * dump content of temorary arrays into histograms
29741       IF ((NEVT.NE.NCEVT).OR.(NEVT.LT.0)) THEN
29742          CALL DT_EVTHIS(IDUM)
29743          NCEVT = NEVT
29744       ENDIF
29745
29746 * check histogram index
29747       IF (IHIS.EQ.-1) RETURN
29748       IF ((IHIS.LT.1).OR.(IHIS.GT.IHISL)) THEN
29749 C        WRITE(LOUT,1000) IHIS,IHISL
29750  1000    FORMAT(1X,'FILHGR:   warning!  histogram index',I4,
29751      &          ' out of range (1..',I3,')')
29752          RETURN
29753       ENDIF
29754
29755       IF ((ISWI(IHIS).EQ.1).OR.(ISWI(IHIS).EQ.3)) THEN
29756 * bin structure not explicitly given
29757          IF ((ISWI(IHIS).EQ.3).AND.(X.GT.ZERO)) X = LOG10(X)
29758          DX = ABS(HIST(1,IHIS,2)-HIST(1,IHIS,1))
29759          IF (X.LT.HIST(1,IHIS,1)) THEN
29760             I1 = 0
29761          ELSE
29762             I1 = INT( (X-HIST(1,IHIS,1))/MAX(DX,TINY) )+1
29763          ENDIF
29764
29765       ELSEIF ((ISWI(IHIS).EQ.2).OR.(ISWI(IHIS).EQ.4)) THEN
29766 * user defined bin structure
29767          IF ((ISWI(IHIS).EQ.4).AND.(X.GT.ZERO)) X = LOG10(X)
29768          IF (X.LT.HIST(1,IHIS,1)) THEN
29769             I1 = 0
29770          ELSE IF (X.GT.HIST(1,IHIS,IBINS(IHIS)+1)) THEN
29771             I1 = IBINS(IHIS)+1
29772          ELSE
29773 *   binary sort algorithm
29774             KMIN = 0
29775             KMAX = IBINS(IHIS)+1
29776     1       CONTINUE
29777             IF ((KMAX-KMIN).EQ.1) GOTO 2
29778             KK = (KMAX+KMIN)/2
29779             IF (X.LE.HIST(1,IHIS,KK)) THEN
29780                KMAX=KK
29781             ELSE
29782                KMIN=KK
29783             ENDIF
29784             GOTO 1
29785     2       CONTINUE
29786             I1 = KMIN
29787          ENDIF
29788
29789       ELSE
29790          WRITE(LOUT,1001)
29791  1001    FORMAT(1X,'FILHGR:   warning!  histogram not initialized')
29792          RETURN
29793       ENDIF
29794
29795 * scoring
29796       IF (I1.LE.0) THEN
29797          TMPUFL(IHIS) = TMPUFL(IHIS)+ONE
29798       ELSEIF (I1.LE.IBINS(IHIS)) THEN
29799          TMPHIS(1,IHIS,I1) = TMPHIS(1,IHIS,I1)+ONE
29800          IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
29801             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+10**X
29802          ELSE
29803             TMPHIS(2,IHIS,I1) = TMPHIS(2,IHIS,I1)+X
29804          ENDIF
29805          TMPHIS(3,IHIS,I1) = TMPHIS(3,IHIS,I1)+Y
29806       ELSE
29807          TMPOFL(IHIS) = TMPOFL(IHIS)+ONE
29808       ENDIF
29809
29810       RETURN
29811       END
29812
29813 *$ CREATE DT_EVTHIS.FOR
29814 *COPY DT_EVTHIS
29815 *
29816 *===evthis=============================================================*
29817 *
29818       SUBROUTINE DT_EVTHIS(NEVT)
29819
29820 ************************************************************************
29821 * Dump content of temorary histograms into /DTHIS1/. This subroutine   *
29822 * is called after each event and for the last event before any call    *
29823 * to OUTHGR.                                                           *
29824 *         NEVT   number of events dumped, this is only needed to       *
29825 *                get the normalization after the last event            *
29826 * This version dated 23.4.95 is written  by S. Roesler.                *
29827 ************************************************************************
29828
29829       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29830       SAVE
29831
29832       PARAMETER ( LINP = 10 ,
29833      &            LOUT = 6 ,
29834      &            LDAT = 9 )
29835
29836       LOGICAL LNOETY
29837
29838       PARAMETER (ZERO = 0.0D0,
29839      &           ONE  = 1.0D0,
29840      &           TINY = 1.0D-10)
29841
29842 * histograms
29843
29844       PARAMETER (NHIS=150, NDIM=250)
29845
29846       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29847      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29848
29849 * auxiliary common for histograms
29850       COMMON /DTHIS2/ TMPHIS(3,NHIS,NDIM),TMPUFL(NHIS),TMPOFL(NHIS)
29851
29852       DATA NCEVT /0/
29853
29854       NCEVT = NCEVT+1
29855       NEVT  = NCEVT
29856
29857       DO 1 I=1,IHISL
29858          LNOETY = .TRUE.
29859          DO 2 J=1,IBINS(I)
29860             IF (TMPHIS(1,I,J).GT.ZERO) THEN
29861                LNOETY = .FALSE.
29862                HIST(2,I,J)   = HIST(2,I,J)+ONE
29863                HIST(7,I,J)   = HIST(7,I,J)+TMPHIS(1,I,J)
29864                DENTRY(2,I)   = DENTRY(2,I)+TMPHIS(1,I,J)
29865                AVX           = TMPHIS(2,I,J)/TMPHIS(1,I,J)
29866                HIST(3,I,J)   = HIST(3,I,J)+TMPHIS(3,I,J)*AVX
29867                HIST(4,I,J)   = HIST(4,I,J)+TMPHIS(3,I,J)*AVX**2
29868                HIST(5,I,J)   = HIST(5,I,J)+TMPHIS(3,I,J)
29869                HIST(6,I,J)   = HIST(6,I,J)+TMPHIS(3,I,J)**2
29870                TMPHIS(1,I,J) = ZERO
29871                TMPHIS(2,I,J) = ZERO
29872                TMPHIS(3,I,J) = ZERO
29873             ENDIF
29874     2    CONTINUE
29875          IF (LNOETY) THEN
29876             IF (TMPUFL(I).GT.ZERO) THEN
29877                UNDERF(I) = UNDERF(I)+ONE
29878                TMPUFL(I) = ZERO
29879             ELSEIF (TMPOFL(I).GT.ZERO) THEN
29880                OVERF(I)  = OVERF(I)+ONE
29881                TMPOFL(I) = ZERO
29882             ENDIF
29883          ELSE
29884             DENTRY(1,I) = DENTRY(1,I)+ONE
29885          ENDIF
29886     1 CONTINUE
29887
29888       RETURN
29889       END
29890
29891 *$ CREATE DT_OUTHGR.FOR
29892 *COPY DT_OUTHGR
29893 *
29894 *===outhgr=============================================================*
29895 *
29896       SUBROUTINE DT_OUTHGR(I1,I2,I3,I4,I5,I6,CHEAD,IHEAD,NEVTS,FAC,
29897      &                  ILOGY,INORM,NMODE)
29898
29899 ************************************************************************
29900 *                                                                      *
29901 *     Plot histogram(s) to standard output unit                        *
29902 *                                                                      *
29903 *         I1..6         indices of histograms to be plotted            *
29904 *         CHEAD,IHEAD   header string,integer                          *
29905 *         NEVTS         number of events                               *
29906 *         FAC           scaling factor                                 *
29907 *         ILOGY   = 1   logarithmic y-axis                             *
29908 *         INORM         normalization                                  *
29909 *                 = 0   no further normalization (FAC is obsolete)     *
29910 *                 = 1   per event and bin width                        *
29911 *                 = 2   per entry and bin width                        *
29912 *                 = 3   per bin entry                                  *
29913 *                 = 4   per event and "bin width" x1^2...x2^2          *
29914 *                 = 5   per event and "log. bin width" ln x1..ln x2    *
29915 *                 = 6   per event                                      *
29916 *         MODE    = 0   no output but normalization applied            *
29917 *                 = 1   all valid histograms separately (small frame)  *
29918 *                       all valid histograms separately (small frame)  *
29919 *                 = -1  and tables as histograms                       *
29920 *                 = 2   all valid histograms (one plot, wide frame)    *
29921 *                       all valid histograms (one plot, wide frame)    *
29922 *                 = -2  and tables as histograms                       *
29923 *                                                                      *
29924 *                                                                      *
29925 *     Note: All histograms to be plotted with one call to this         *
29926 *           subroutine and |MODE|=2 must have the same bin structure!  *
29927 *           There is no test included ensuring this fact.              *
29928 *                                                                      *
29929 * This version dated 23.4.95 is written  by S. Roesler.                *
29930 ************************************************************************
29931
29932       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
29933       SAVE
29934
29935       PARAMETER ( LINP = 10 ,
29936      &            LOUT = 6 ,
29937      &            LDAT = 9 )
29938
29939       CHARACTER*72 CHEAD
29940
29941       PARAMETER (ZERO   =  0.0D0,
29942      &           IZERO  =  0,
29943      &           ONE    =  1.0D0,
29944      &           TWO    =  2.0D0,
29945      &           OHALF  =  0.5D0,
29946      &           EPS    =  1.0D-5,
29947      &           TINY   =  1.0D-8,
29948      &           SMALL  =  -1.0D8,
29949      &           RLARGE =  1.0D8 )
29950
29951 * histograms
29952
29953       PARAMETER (NHIS=150, NDIM=250)
29954
29955       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
29956      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
29957
29958       PARAMETER (NDIM2 = 2*NDIM)
29959       DIMENSION XX(NDIM2),YY(NDIM2)
29960
29961       PARAMETER (NHISTO = 6)
29962       DIMENSION YY1(NDIM,NHISTO),XX1(NDIM,NHISTO),IDX1(NHISTO),
29963      &          IDX(NHISTO)
29964
29965       CHARACTER*43 CNORM(0:8)
29966       DATA CNORM /'no further normalization                   ',
29967      &            'per event and bin width                    ',
29968      &            'per entry1 and bin width                   ',
29969      &            'per bin entry                              ',
29970      &            'per event and "bin width" x1^2...x2^2      ',
29971      &            'per event and "log. bin width" ln x1..ln x2',
29972      &            'per event                                  ',
29973      &            'per bin entry1                             ',
29974      &            'per entry2 and bin width                   '/
29975
29976       IDX1(1) = I1
29977       IDX1(2) = I2
29978       IDX1(3) = I3
29979       IDX1(4) = I4
29980       IDX1(5) = I5
29981       IDX1(6) = I6
29982
29983       MODE = NMODE
29984
29985 * initialization if "wide frame" is requested
29986       IF (ABS(MODE).EQ.2) THEN
29987          DO 1 I=1,NHISTO
29988             DO 2 J=1,NDIM
29989                XX1(J,I) = ZERO
29990                YY1(J,I) = ZERO
29991     2       CONTINUE
29992     1    CONTINUE
29993       ENDIF
29994
29995 * plot header
29996       WRITE(LOUT,'(/1X,A,I3,/,1X,70A1)') CHEAD,IHEAD,('=',II=1,70)
29997
29998 * check histogram indices
29999       NHI = 0
30000       DO 3 I=1,NHISTO
30001          IF ((IDX1(I).GE.1).AND.(IDX1(I).LE.IHISL)) THEN
30002             IF (ISWI(IDX1(I)).NE.0) THEN
30003                IF (DENTRY(1,IDX1(I)).LT.ONE) THEN
30004                   WRITE(LOUT,1000)
30005      &                 IDX1(I),UNDERF(IDX1(I)),OVERF(IDX1(I))
30006  1000             FORMAT(/,1X,'OUTHGR:   warning!  no entries in',
30007      &                   ' histogram ',I3,/,21X,'underflows:',F10.0,
30008      &                   '   overflows:  ',F10.0)
30009                ELSE
30010                   NHI = NHI+1
30011                   IDX(NHI) = IDX1(I)
30012                ENDIF
30013             ENDIF
30014          ENDIF
30015     3 CONTINUE
30016       IF (NHI.EQ.0) THEN
30017          WRITE(LOUT,1001)
30018  1001    FORMAT(/,1X,'OUTHGR:   warning!  histogram indices not valid')
30019          RETURN
30020       ENDIF
30021
30022 * check normalization request
30023       IF ( ((FAC.EQ.ZERO).AND.(INORM.NE.0)).OR.
30024      &     ((NEVTS.LT.1).AND.((INORM.EQ.1).OR.(INORM.EQ.4).OR.
30025      &                        (INORM.EQ.5).OR.(INORM.EQ.6))).OR.
30026      &     (INORM.LT.0).OR.(INORM.GT.8) ) THEN
30027          WRITE(LOUT,1002) NEVTS,INORM,FAC
30028  1002    FORMAT(/,1X,'OUTHGR:   warning!  normalization request not ',
30029      &          'valid',/,21X,'NEVTS = ',I7,4X,'INORM = ',I2,4X,
30030      &          'FAC = ',E11.4)
30031          RETURN
30032       ENDIF
30033
30034       WRITE(LOUT,'(/,1X,A,I8)') 'number of events:',NEVTS
30035
30036 * apply normalization
30037       DO 4 N=1,NHI
30038
30039          I = IDX(N)
30040
30041          IF (ISWI(I).EQ.1) THEN
30042             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30043  1003       FORMAT(/,1X,'histo.',I4,', linear binning from',2X,E10.4,
30044      &             ' to',2X,E10.4,',',2X,I3,' bins')
30045          ELSEIF (ISWI(I).EQ.2) THEN
30046             WRITE(LOUT,1003) I,HIST(1,I,1),HIST(1,I,IBINS(I)+1),IBINS(I)
30047             WRITE(LOUT,1007)
30048  1007       FORMAT(1X,'user defined bin structure')
30049          ELSEIF (ISWI(I).EQ.3) THEN
30050             WRITE(LOUT,1004)
30051      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30052  1004       FORMAT(/,1X,'histo.',I4,', logar. binning from',2X,E10.4,
30053      &             ' to',2X,E10.4,',',2X,I3,' bins')
30054          ELSEIF (ISWI(I).EQ.4) THEN
30055             WRITE(LOUT,1004)
30056      &         I,10**HIST(1,I,1),10**HIST(1,I,IBINS(I)+1),IBINS(I)
30057             WRITE(LOUT,1007)
30058          ELSE
30059             WRITE(LOUT,1008) ISWI(I)
30060  1008       FORMAT(/,1X,'warning!  inconsistent bin structure flag ',I4)
30061          ENDIF
30062          WRITE(LOUT,1005) DENTRY(1,I),DENTRY(2,I),UNDERF(I),OVERF(I)
30063  1005    FORMAT(13X,'entries:',2F9.0,' underfl.:',F8.0,
30064      &          ' overfl.:',F8.0)
30065          WRITE(LOUT,1009) CNORM(INORM)
30066  1009    FORMAT(1X,'normalization: ',A,/)
30067
30068          DO 5 K=1,IBINS(I)
30069             CALL DT_GETBIN(I,K,NEVTS,INORM,XLOW,XHI,XMEAN,YMEAN,YERR)
30070             YMEAN = FAC*YMEAN
30071             YERR  = FAC*YERR
30072             WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,YERR,HIST(2,I,K)
30073             WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,YERR,HIST(2,I,K)
30074  1006       FORMAT(1X,5E11.3)
30075 *    small frame
30076             II = 2*K
30077             XX(II-1) = HIST(1,I,K)
30078             XX(II)   = HIST(1,I,K+1)
30079             YY(II-1) = YMEAN
30080             YY(II)   = YMEAN
30081 *    wide frame
30082             XX1(K,N) = XMEAN
30083             IF ((ISWI(I).EQ.3).OR.(ISWI(I).EQ.4))
30084      &         XX1(K,N) = LOG10(XMEAN)
30085             YY1(K,N) = YMEAN
30086     5    CONTINUE
30087
30088 * plot small frame
30089          IF (ABS(MODE).EQ.1) THEN
30090             IBIN2 = 2*IBINS(I)
30091             WRITE(LOUT,'(/,1X,A)') 'Preview:'
30092             IF(ILOGY.EQ.1) THEN
30093               CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30094             ELSE
30095               CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30096             ENDIF
30097          ENDIF
30098
30099     4 CONTINUE
30100
30101 * plot wide frame
30102       IF (ABS(MODE).EQ.2) THEN
30103          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30104          NSIZE = NDIM*NHISTO
30105          DXLOW = HIST(1,IDX(1),1)
30106          DDX   = ABS(HIST(1,IDX(1),2)-HIST(1,IDX(1),1))
30107          YLOW  = RLARGE
30108          YHI   = SMALL
30109          DO 6 I=1,NHISTO
30110             DO 7 J=1,NDIM
30111                IF (YY1(J,I).LT.YLOW) THEN
30112                   IF (ILOGY.EQ.1) THEN
30113                      IF (YY1(J,I).GT.ZERO) YLOW = YY1(J,I)
30114                   ELSE
30115                      YLOW = YY1(J,I)
30116                   ENDIF
30117                ENDIF
30118                IF (YY1(J,I).GT.YHI) YHI = YY1(J,I)
30119     7       CONTINUE
30120     6    CONTINUE
30121          DY = (YHI-YLOW)/DBLE(NDIM)
30122          IF (DY.LE.ZERO) THEN
30123             WRITE(LOUT,'(1X,A,6I4,A,2E12.4)')
30124      &         'OUTHGR:   warning! zero bin width for histograms ',
30125      &         IDX,': ',YLOW,YHI
30126             RETURN
30127          ENDIF
30128          IF (ILOGY.EQ.1) THEN
30129             YLOW = LOG10(YLOW)
30130             DY   = (LOG10(YHI)-YLOW)/100.0D0
30131             DO 8 I=1,NHISTO
30132                DO 9 J=1,NDIM
30133                   IF (YY1(J,I).LE.ZERO) THEN
30134                      YY1(J,I) = YLOW
30135                   ELSE
30136                      YY1(J,I) = LOG10(YY1(J,I))
30137                   ENDIF
30138     9          CONTINUE
30139     8       CONTINUE
30140          ENDIF
30141          CALL DT_SRPLOT(XX1,YY1,NSIZE,NHISTO,NDIM,DXLOW,DDX,YLOW,DY)
30142       ENDIF
30143
30144       RETURN
30145       END
30146
30147 *$ CREATE DT_GETBIN.FOR
30148 *COPY DT_GETBIN
30149 *
30150 *===getbin=============================================================*
30151 *
30152       SUBROUTINE DT_GETBIN(IHIS,IBIN,KEVT,NORM,XLOW,XHI,
30153      &                  XMEAN,YMEAN,YERR)
30154
30155 ************************************************************************
30156 * This version dated 23.4.95 is written  by S. Roesler.                *
30157 ************************************************************************
30158
30159       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30160       SAVE
30161
30162       PARAMETER ( LINP = 10 ,
30163      &            LOUT = 6 ,
30164      &            LDAT = 9 )
30165
30166       PARAMETER (ZERO   = 0.0D0,
30167      &           ONE    = 1.0D0,
30168      &           TINY35 = 1.0D-35)
30169
30170 * histograms
30171
30172       PARAMETER (NHIS=150, NDIM=250)
30173
30174       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30175      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30176
30177       XLOW = HIST(1,IHIS,IBIN)
30178       XHI  = HIST(1,IHIS,IBIN+1)
30179       IF ((ISWI(IHIS).EQ.3).OR.(ISWI(IHIS).EQ.4)) THEN
30180          XLOW = 10**XLOW
30181          XHI  = 10**XHI
30182       ENDIF
30183       IF (NORM.EQ.2) THEN
30184          DX   = XHI-XLOW
30185          NEVT = INT(DENTRY(1,IHIS))
30186       ELSEIF (NORM.EQ.3) THEN
30187          DX   = ONE
30188          NEVT = INT(HIST(2,IHIS,IBIN))
30189       ELSEIF (NORM.EQ.4) THEN
30190          DX   = XHI**2-XLOW**2
30191          NEVT = KEVT
30192       ELSEIF (NORM.EQ.5) THEN
30193          DX   = LOG(ABS(XHI))-LOG(ABS(XLOW))
30194          NEVT = KEVT
30195       ELSEIF (NORM.EQ.6) THEN
30196          DX   = ONE
30197          NEVT = KEVT
30198       ELSEIF (NORM.EQ.7) THEN
30199          DX   = ONE
30200          NEVT = INT(HIST(7,IHIS,IBIN))
30201       ELSEIF (NORM.EQ.8) THEN
30202          DX   = XHI-XLOW
30203          NEVT = INT(DENTRY(2,IHIS))
30204       ELSE
30205          DX   = ABS(XHI-XLOW)
30206          NEVT = KEVT
30207       ENDIF
30208       IF (ABS(DX).LT.TINY35) DX = ONE
30209       NEVT   = MAX(NEVT,1)
30210       YMEAN  = HIST(5,IHIS,IBIN)/DX/DBLE(NEVT)
30211       YMEAN2 = HIST(6,IHIS,IBIN)/DX**2/DBLE(NEVT)
30212       YERR   = SQRT(ABS(YMEAN2-YMEAN**2))/SQRT(DBLE(NEVT))
30213       YSUM   = HIST(5,IHIS,IBIN)
30214       IF (ABS(YSUM).LT.TINY35) YSUM = ONE
30215 C     XMEAN  = HIST(3,IHIS,IBIN)/YSUM/MAX(HIST(2,IHIS,IBIN),ONE)
30216       XMEAN  = HIST(3,IHIS,IBIN)/YSUM
30217       IF (XMEAN.EQ.ZERO) XMEAN = XLOW
30218
30219       RETURN
30220       END
30221
30222 *$ CREATE DT_JOIHIS.FOR
30223 *COPY DT_JOIHIS
30224 *
30225 *===joihis=============================================================*
30226 *
30227       SUBROUTINE DT_JOIHIS(IH1,IH2,COPER,FAC1,FAC2,KEVT,NORM,ILOGY,MODE)
30228
30229 ************************************************************************
30230 *                                                                      *
30231 *     Operation on histograms.                                         *
30232 *                                                                      *
30233 *     input:  IH1,IH2      histogram indices to be joined              *
30234 *             COPER        character defining the requested operation, *
30235 *                          i.e. '+', '-', '*', '/'                     *
30236 *             FAC1,FAC2    factors for joining, i.e.                   *
30237 *                          FAC1*histo1 COPER FAC2*histo2               *
30238 *                                                                      *
30239 * This version dated 23.4.95 is written  by S. Roesler.                *
30240 ************************************************************************
30241
30242       IMPLICIT DOUBLE PRECISION(A-H,O-Z)
30243       SAVE
30244
30245       PARAMETER ( LINP = 10 ,
30246      &            LOUT = 6 ,
30247      &            LDAT = 9 )
30248
30249       CHARACTER COPER*1
30250
30251       PARAMETER (ZERO   =  0.0D0,
30252      &           ONE    =  1.0D0,
30253      &           OHALF  =  0.5D0,
30254      &           TINY8  =  1.0D-8,
30255      &           SMALL  =  -1.0D8,
30256      &           RLARGE =  1.0D8 )
30257
30258 * histograms
30259
30260       PARAMETER (NHIS=150, NDIM=250)
30261
30262       COMMON /DTHIS1/ HIST(7,NHIS,NDIM),DENTRY(2,NHIS),OVERF(NHIS),
30263      &                UNDERF(NHIS),IBINS(NHIS),ISWI(NHIS),IHISL
30264
30265       PARAMETER (NDIM2 = 2*NDIM)
30266       DIMENSION XX(NDIM2),YY(NDIM2),YY1(NDIM),XX1(NDIM)
30267
30268       CHARACTER*43 CNORM(0:6)
30269       DATA CNORM /'no further normalization                   ',
30270      &            'per event and bin width                    ',
30271      &            'per entry and bin width                    ',
30272      &            'per bin entry                              ',
30273      &            'per event and "bin width" x1^2...x2^2      ',
30274      &            'per event and "log. bin width" ln x1..ln x2',
30275      &            'per event                                  '/
30276
30277 * check histogram indices
30278       IF ((IH1.LT.    1).OR.(IH2.LT.    1).OR.
30279      &    (IH1.GT.IHISL).OR.(IH2.GT.IHISL)) THEN
30280          WRITE(LOUT,1000) IH1,IH2,IHISL
30281  1000    FORMAT(1X,'JOIHIS:   warning!  inconsistent histogram ',
30282      &          'indices (',I3,',',I3,'),',/,21X,'valid range:  1,',I3)
30283          GOTO 9999
30284       ENDIF
30285
30286 * check bin structure of histograms to be joined
30287       IF (IBINS(IH1).NE.IBINS(IH2)) THEN
30288          WRITE(LOUT,1001) IH1,IH2,IBINS(IH1),IBINS(IH2)
30289  1001    FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30290      &          ' and ',I3,' failed',/,21X,
30291      &          'due to different numbers of bins (',I3,',',I3,')')
30292          GOTO 9999
30293       ENDIF
30294       DO 1 K=1,IBINS(IH1)+1
30295          IF (ABS(HIST(1,IH1,K)-HIST(1,IH2,K)).GT.TINY8) THEN
30296             WRITE(LOUT,1002) IH1,IH2,K,HIST(1,IH1,K),HIST(1,IH2,K)
30297  1002       FORMAT(1X,'JOIHIS:   warning!  joining histograms ',I3,
30298      &             ' and ',I3,' failed at bin edge ',I3,/,21X,
30299      &             'X1,X2 = ',2E11.4)
30300             GOTO 9999
30301          ENDIF
30302     1 CONTINUE
30303
30304       WRITE(LOUT,1003) IH1,IH2,COPER,FAC1,FAC2
30305  1003 FORMAT(1X,'JOIHIS:   joining histograms ',I3,',',I3,' with ',
30306      &       'operation ',A,/,11X,'and factors ',2E11.4)
30307       WRITE(LOUT,1004) CNORM(NORM)
30308  1004 FORMAT(1X,'normalization: ',A,/)
30309
30310       DO 2 K=1,IBINS(IH1)
30311          CALL DT_GETBIN(IH1,K,KEVT,NORM,XLOW1,XHI1,XMEAN1,YMEAN1,YERR1)
30312          CALL DT_GETBIN(IH2,K,KEVT,NORM,XLOW2,XHI2,XMEAN2,YMEAN2,YERR2)
30313          XLOW  = XLOW1
30314          XHI   = XHI1
30315          XMEAN = OHALF*(XMEAN1+XMEAN2)
30316          IF (COPER.EQ.'+') THEN
30317             YMEAN = FAC1*YMEAN1+FAC2*YMEAN2
30318          ELSEIF (COPER.EQ.'*') THEN
30319             YMEAN = FAC1*YMEAN1*FAC2*YMEAN2
30320          ELSEIF (COPER.EQ.'/') THEN
30321             IF (YMEAN2.EQ.ZERO) THEN
30322                YMEAN = ZERO
30323             ELSE
30324                IF (FAC2.EQ.ZERO) FAC2 = ONE
30325                YMEAN = FAC1*YMEAN1/(FAC2*YMEAN2)
30326             ENDIF
30327          ELSE
30328             GOTO 9998
30329          ENDIF
30330          WRITE(LOUT,1006) XLOW,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30331          WRITE(LOUT,1006) XHI ,XMEAN,YMEAN,HIST(2,IH1,K),HIST(2,IH2,K)
30332  1006    FORMAT(1X,5E11.3)
30333 *    small frame
30334          II = 2*K
30335          XX(II-1) = HIST(1,IH1,K)
30336          XX(II)   = HIST(1,IH1,K+1)
30337          YY(II-1) = YMEAN
30338          YY(II)   = YMEAN
30339 *    wide frame
30340          XX1(K) = XMEAN
30341          IF ((ISWI(IH1).EQ.3).OR.(ISWI(IH1).EQ.4)) XX1(K) = LOG10(XMEAN)
30342          YY1(K) = YMEAN
30343     2 CONTINUE
30344
30345 * plot small frame
30346       IF (ABS(MODE).EQ.1) THEN
30347          IBIN2 = 2*IBINS(IH1)
30348          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30349          IF(ILOGY.EQ.1) THEN
30350            CALL DT_XGLOGY(IBIN2,1,XX,YY,YY)
30351          ELSE
30352            CALL DT_XGRAPH(IBIN2,1,XX,YY,YY)
30353          ENDIF
30354       ENDIF
30355
30356 * plot wide frame
30357       IF (ABS(MODE).EQ.2) THEN
30358          WRITE(LOUT,'(/,1X,A)') 'Preview:'
30359          NSIZE = NDIM
30360          DXLOW = HIST(1,IH1,1)
30361          DDX   = ABS(HIST(1,IH1,2)-HIST(1,IH1,1))
30362          YLOW  = RLARGE
30363          YHI   = SMALL
30364          DO 3 I=1,NDIM
30365             IF (YY1(I).LT.YLOW) THEN
30366                IF (ILOGY.EQ.1) THEN
30367                   IF (YY1(I).GT.ZERO) YLOW = YY1(I)
30368                ELSE
30369                   YLOW = YY1(I)
30370                ENDIF
30371             ENDIF
30372             IF (YY1(I).GT.YHI) YHI = YY1(I)
30373     3    CONTINUE
30374          DY = (YHI-YLOW)/DBLE(NDIM)
30375          IF (DY.LE.ZERO) THEN
30376             WRITE(LOUT,'(1X,A,2I4,A,2E12.4)')
30377      &         'JOIHIS:   warning! zero bin width for histograms ',
30378      &         IH1,IH2,': ',YLOW,YHI
30379             RETURN
30380          ENDIF
30381          IF (ILOGY.EQ.1) THEN
30382             YLOW = LOG10(YLOW)
30383             DY   = (LOG10(YHI)-YLOW)/100.0D0
30384             DO 4 I=1,NDIM
30385                IF (YY1(I).LE.ZERO) THEN
30386                   YY1(I) = YLOW
30387                ELSE
30388                   YY1(I) = LOG10(YY1(I))
30389                ENDIF
30390     4       CONTINUE
30391          ENDIF
30392          CALL DT_SRPLOT(XX1,YY1,NSIZE,1,NDIM,DXLOW,DDX,YLOW,DY)
30393       ENDIF
30394
30395       RETURN
30396
30397  9998 CONTINUE
30398       WRITE(LOUT,1005) COPER
30399  1005 FORMAT(1X,'JOIHIS:   unknown operation ',A)
30400
30401  9999 CONTINUE
30402       RETURN
30403       END
30404
30405 *$ CREATE DT_XGRAPH.FOR
30406 *COPY DT_XGRAPH
30407 *
30408 *===qgraph=============================================================*
30409 *
30410       SUBROUTINE DT_XGRAPH(N,IARG,X,Y1,Y2)
30411 C***********************************************************************
30412 C
30413 C     calculate quasi graphic picture with 25 lines and 79 columns
30414 C     ranges will be chosen automatically
30415 C
30416 C     input     N          dimension of input fields
30417 C               IARG       number of curves (fields) to plot
30418 C               X          field of X
30419 C               Y1         field of Y1
30420 C               Y2         field of Y2
30421 C
30422 C This subroutine is written by R. Engel.
30423 C***********************************************************************
30424       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30425       SAVE
30426
30427       PARAMETER ( LINP = 10 ,
30428      &            LOUT = 6 ,
30429      &            LDAT = 9 )
30430
30431 C
30432       DIMENSION X(N),Y1(N),Y2(N)
30433       PARAMETER (EPS=1.D-30)
30434       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30435       CHARACTER SYMB(5)
30436       CHARACTER COL(0:149,0:49)
30437 C
30438       DATA SYMB /'0','e','z','#','x'/
30439 C
30440       ISPALT=IBREIT-10
30441 C
30442 C***  automatic range fitting
30443 C
30444       XMAX=X(1)
30445       XMIN=X(1)
30446       DO 600 I=1,N
30447          XMAX=MAX(X(I),XMAX)
30448          XMIN=MIN(X(I),XMIN)
30449  600  CONTINUE
30450       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30451 C
30452       ITEST=0
30453       DO 1100 K=0,IZEIL-1
30454          ITEST=ITEST+1
30455          IF (ITEST.EQ.IYRAST) THEN
30456             DO 1010 L=1,ISPALT-1
30457                COL(L,K)='-'
30458 1010        CONTINUE
30459             COL(ISPALT,K)='+'
30460             ITEST=0
30461             DO 1020 L=0,ISPALT-1,IXRAST
30462                COL(L,K)='+'
30463 1020        CONTINUE
30464          ELSE
30465             DO 1030 L=1,ISPALT-1
30466                COL(L,K)=' '
30467 1030        CONTINUE
30468             DO 1040 L=0,ISPALT-1,IXRAST
30469                COL(L,K)='|'
30470 1040        CONTINUE
30471             COL(ISPALT,K)='|'
30472          ENDIF
30473 1100  CONTINUE
30474 C
30475 C***  plot curve Y1
30476 C
30477       YMAX=Y1(1)
30478       YMIN=Y1(1)
30479       DO 500 I=1,N
30480          YMAX=MAX(Y1(I),YMAX)
30481          YMIN=MIN(Y1(I),YMIN)
30482 500   CONTINUE
30483       IF(IARG.GT.1) THEN
30484         DO 550 I=1,N
30485            YMAX=MAX(Y2(I),YMAX)
30486            YMIN=MIN(Y2(I),YMIN)
30487 550     CONTINUE
30488       ENDIF
30489       YMAX=(YMAX-YMIN)/40.0D0+YMAX
30490       YMIN=YMIN-(YMAX-YMIN)/40.0D0
30491       YZOOM=(YMAX-YMIN)/DBLE(IZEIL)
30492       IF(YZOOM.LT.EPS) THEN
30493         WRITE(LOUT,'(1X,A)')
30494      &    'XGRAPH:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30495         RETURN
30496       ENDIF
30497 C
30498 C***  plot curve Y1
30499 C
30500       ILAST=-1
30501       LLAST=-1
30502       DO 1200 K=1,N
30503          L=NINT((X(K)-XMIN)/XZOOM)
30504          I=NINT((YMAX-Y1(K))/YZOOM)
30505          IF(ILAST.GE.0) THEN
30506            LD = L-LLAST
30507            ID = I-ILAST
30508            DO 55 II=0,LD,SIGN(1,LD)
30509              DO 66 KK=0,ID,SIGN(1,ID)
30510                COL(II+LLAST,KK+ILAST)=SYMB(1)
30511  66          CONTINUE
30512  55        CONTINUE
30513          ELSE
30514            COL(L,I)=SYMB(1)
30515          ENDIF
30516          ILAST = I
30517          LLAST = L
30518 1200  CONTINUE
30519 C
30520       IF(IARG.GT.1) THEN
30521 C
30522 C***  plot curve Y2
30523 C
30524         DO 1250 K=1,N
30525            L=NINT((X(K)-XMIN)/XZOOM)
30526            I=NINT((YMAX-Y2(K))/YZOOM)
30527            COL(L,I)=SYMB(2)
30528 1250    CONTINUE
30529       ENDIF
30530 C
30531 C***  write it
30532 C
30533       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30534 C
30535 C***  write range of X
30536 C
30537       XZOOM = (XMAX-XMIN)/DBLE(7)
30538       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30539 C
30540       DO 1300 K=0,IZEIL-1
30541          YPOS=YMAX-((DBLE(K)+0.5D0)*YZOOM)
30542          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30543  110     FORMAT(1X,1PE9.2,70A1)
30544 1300  CONTINUE
30545 C
30546 C***  write range of X
30547 C
30548       XZOOM = (XMAX-XMIN)/DBLE(7)
30549       WRITE(LOUT,120) (XZOOM*DBLE(I-1)+XMIN,I=1,7)
30550       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30551  120  FORMAT(6X,7(1PE10.3))
30552       END
30553
30554 *$ CREATE DT_XGLOGY.FOR
30555 *COPY DT_XGLOGY
30556 *
30557 *===qglogy=============================================================*
30558 *
30559       SUBROUTINE DT_XGLOGY(N,IARG,X,Y1,Y2)
30560 C***********************************************************************
30561 C
30562 C     calculate quasi graphic picture with 25 lines and 79 columns
30563 C     logarithmic y axis
30564 C     ranges will be chosen automatically
30565 C
30566 C     input     N          dimension of input fields
30567 C               IARG       number of curves (fields) to plot
30568 C               X          field of X
30569 C               Y1         field of Y1
30570 C               Y2         field of Y2
30571 C
30572 C This subroutine is written by R. Engel.
30573 C***********************************************************************
30574 C
30575       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30576       SAVE
30577
30578       PARAMETER ( LINP = 10 ,
30579      &            LOUT = 6 ,
30580      &            LDAT = 9 )
30581
30582       DIMENSION X(N),Y1(N),Y2(N)
30583       PARAMETER (EPS=1.D-30)
30584       PARAMETER (IYRAST=5,IXRAST=10,IBREIT=79,IZEIL=20)
30585       CHARACTER SYMB(5)
30586       CHARACTER COL(0:149,0:49)
30587       PARAMETER (DEPS = 1.D-10)
30588 C
30589       DATA SYMB /'0','e','z','#','x'/
30590 C
30591       ISPALT=IBREIT-10
30592 C
30593 C***  automatic range fitting
30594 C
30595       XMAX=X(1)
30596       XMIN=X(1)
30597       DO 600 I=1,N
30598          XMAX=MAX(X(I),XMAX)
30599          XMIN=MIN(X(I),XMIN)
30600  600  CONTINUE
30601       XZOOM=(XMAX-XMIN)/DBLE(ISPALT)
30602 C
30603       ITEST=0
30604       DO 1100 K=0,IZEIL-1
30605          ITEST=ITEST+1
30606          IF (ITEST.EQ.IYRAST) THEN
30607             DO 1010 L=1,ISPALT-1
30608                COL(L,K)='-'
30609 1010        CONTINUE
30610             COL(ISPALT,K)='+'
30611             ITEST=0
30612             DO 1020 L=0,ISPALT-1,IXRAST
30613                COL(L,K)='+'
30614 1020        CONTINUE
30615          ELSE
30616             DO 1030 L=1,ISPALT-1
30617                COL(L,K)=' '
30618 1030        CONTINUE
30619             DO 1040 L=0,ISPALT-1,IXRAST
30620                COL(L,K)='|'
30621 1040        CONTINUE
30622             COL(ISPALT,K)='|'
30623          ENDIF
30624 1100  CONTINUE
30625 C
30626 C***  plot curve Y1
30627 C
30628       YMAX=Y1(1)
30629       YMIN=MAX(Y1(1),EPS)
30630       DO 500 I=1,N
30631          YMAX =MAX(Y1(I),YMAX)
30632          IF(Y1(I).GT.EPS) THEN
30633            IF(YMIN.EQ.EPS) THEN
30634              YMIN = Y1(I)/10.D0
30635            ELSE
30636              YMIN = MIN(Y1(I),YMIN)
30637            ENDIF
30638          ENDIF
30639 500   CONTINUE
30640       IF(IARG.GT.1) THEN
30641         DO 550 I=1,N
30642            YMAX=MAX(Y2(I),YMAX)
30643            IF(Y2(I).GT.EPS) THEN
30644              IF(YMIN.EQ.EPS) THEN
30645                YMIN = Y2(I)
30646              ELSE
30647                YMIN = MIN(Y2(I),YMIN)
30648              ENDIF
30649            ENDIF
30650 550     CONTINUE
30651       ENDIF
30652 C
30653       DO 560 I=1,N
30654         Y1(I) = MAX(Y1(I),YMIN)
30655  560  CONTINUE
30656       IF(IARG.GT.1) THEN
30657         DO 570 I=1,N
30658           Y2(I) = MAX(Y2(I),YMIN)
30659  570    CONTINUE
30660       ENDIF
30661 C
30662       IF(YMAX.LE.YMIN) THEN
30663         WRITE(LOUT,'(/1X,A,2E12.3,/)')
30664      &     'XGLOGY:ERROR:YMIN,YMAX ',YMIN,YMAX
30665         WRITE(LOUT,'(1X,A)') 'MIN = MAX, OUTPUT SUPPRESSED'
30666         RETURN
30667       ENDIF
30668 C
30669       YMA=(LOG10(YMAX)-LOG10(YMIN))/20.0D0+LOG10(YMAX)
30670       YMI=LOG10(YMIN)-(LOG10(YMAX)-LOG10(YMIN))/20.0D0
30671       YZOOM=(YMA-YMI)/DBLE(IZEIL)
30672       IF(YZOOM.LT.EPS) THEN
30673         WRITE(LOUT,'(1X,A)')
30674      &    'XGLOGY:WARNING: MIN = MAX, OUTPUT SUPPRESSED'
30675         RETURN
30676       ENDIF
30677 C
30678 C***  plot curve Y1
30679 C
30680       ILAST=-1
30681       LLAST=-1
30682       DO 1200 K=1,N
30683          L=NINT((X(K)-XMIN)/XZOOM)
30684          I=NINT((YMA-LOG10(Y1(K)))/YZOOM)
30685          IF(ILAST.GE.0) THEN
30686            LD = L-LLAST
30687            ID = I-ILAST
30688            DO 55 II=0,LD,SIGN(1,LD)
30689              DO 66 KK=0,ID,SIGN(1,ID)
30690                COL(II+LLAST,KK+ILAST)=SYMB(1)
30691  66          CONTINUE
30692  55        CONTINUE
30693          ELSE
30694            COL(L,I)=SYMB(1)
30695          ENDIF
30696          ILAST = I
30697          LLAST = L
30698 1200  CONTINUE
30699 C
30700       IF(IARG.GT.1) THEN
30701 C
30702 C***  plot curve Y2
30703 C
30704         DO 1250 K=1,N
30705            L=NINT((X(K)-XMIN)/XZOOM)
30706            I=NINT((YMA-LOG10(Y2(K)))/YZOOM)
30707            COL(L,I)=SYMB(2)
30708 1250    CONTINUE
30709       ENDIF
30710 C
30711 C***  write it
30712 C
30713       WRITE(LOUT,'(2X,A)') '(LOGARITHMIC Y AXIS)'
30714       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30715 C
30716 C***  write range of X
30717 C
30718       XZOOM1 = (XMAX-XMIN)/DBLE(7)
30719       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30720 C
30721       DO 1300 K=0,IZEIL-1
30722          YPOS=10.D0**(YMA-((DBLE(K)+0.5D0)*YZOOM))
30723          WRITE(LOUT,110) YPOS,(COL(I,K),I=0,ISPALT)
30724  110     FORMAT(1X,1PE9.2,70A1)
30725 1300  CONTINUE
30726 C
30727 C***  write range of X
30728 C
30729       WRITE(LOUT,120) (XZOOM1*DBLE(I-1)+XMIN,I=1,7)
30730       WRITE(LOUT,'(1X,79A)') ('-',I=1,IBREIT)
30731  120  FORMAT(6X,7(1PE10.3))
30732 C
30733       END
30734
30735 *$ CREATE DT_SRPLOT.FOR
30736 *COPY DT_SRPLOT
30737 *
30738 *===plot===============================================================*
30739 *
30740       SUBROUTINE DT_SRPLOT(X,Y,N,M,MM,XO,DX,YO,DY)
30741
30742       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30743       SAVE
30744
30745       PARAMETER ( LINP = 10 ,
30746      &            LOUT = 6 ,
30747      &            LDAT = 9 )
30748
30749 *
30750 *     initial version
30751 *     J. Ranft, (FORTRAN-Programmierung,J.R.,Teubner, Leipzig, 72)
30752 *     This is a subroutine of fluka to plot Y across the page
30753 *     as a function of X down the page. Up to 37 curves can be
30754 *     plotted in the same picture with different plotting characters.
30755 *     Output of first 10 overprinted characters addad by FB 88
30756 *  - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
30757 *
30758 *     Input Variables:
30759 *        X   = array containing the values of X
30760 *        Y   = array containing the values of Y
30761 *        N   = number of values in X and in Y
30762 *              can exceed the fixed number of lines
30763 *        M   = number of different curves X,Y are containing
30764 *        MM  = number of points in each curve i.e. N=M*MM
30765 *        XO  = smallest value of X to be plotted
30766 *        DX  = increment of X between subsequent lines
30767 *        YO  = smallest value of Y to be plotted
30768 *        DY  = increment of Y between subsequent character spaces
30769 *
30770 *        other variables used inside:
30771 *        XX  = numbers along the X-coordinate axis
30772 *        YY  = numbers along the Y-coordinate axis
30773 *        LL  = ten lines temporary storage for the plot
30774 *        L   = character set used to plot different curves
30775 *        LOV = memorizes overprinted symbols
30776 *              the first 10 overprinted symbols are printed on
30777 *              the end of the line to avoid ambiguities
30778 *              (added by FB as considered quite helpful)
30779 *
30780 *********************************************************************
30781 *
30782       DIMENSION XX(61),YY(61),LL(101,10)
30783       DIMENSION X(N),Y(N),L(40),LOV(40,10)
30784       INTEGER*4 LL, L, LOV
30785       DATA  L/
30786      11H*,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9,1HZ,
30787      21H+,1HA,1HO,1HB,1HC,1HD,1HE,1HF,1HG,1HH,
30788      31HI,1HJ,1HK,1HL,1HM,1HN,1HO,1HP,1HQ,1HR,
30789      41HS,1HT,1HU,1HV,1HW,1HX,1HY,1H1,1H-,1H  /
30790 *
30791 *
30792       MN=51
30793       DO 10 I=1,MN
30794         AI=I-1
30795    10 XX(I)=XO+AI*DX
30796       DO 20 I=1,11
30797         AI=I-1
30798    20 YY(I)=YO+10.0D0*AI*DY
30799       WRITE(LOUT, 500) (YY(I),I=1,11)
30800       MMN=MN-1
30801 *
30802 *
30803       DO 90 JJ=1,MMN,10
30804         JJJ=JJ-1
30805         DO 30 I=1,101
30806           DO 30 J=1,10
30807    30   LL(I,J)=L(40)
30808         DO 40 I=1,101
30809    40   LL(I,1)=L(39)
30810         DO 50 I=1,101,10
30811           DO 50 J=1,10
30812    50   LL(I,J)=L(38)
30813         DO 60 I=1,40
30814           DO 60 J=1,10
30815    60   LOV(I,J)=L(40)
30816 *
30817 *
30818         DO 70 I=1,M
30819           DO 70 J=1,MM
30820             II=J+(I-1)*MM
30821             AIX=(X(II)-(XO-DX/2.0D0))/DX+1.0D0
30822             AIY=(Y(II)-(YO-DY/2.0D0))/DY+1.0D0
30823             AIX=AIX-DBLE(JJJ)
30824 *           changed Sept.88 by FB to avoid INTEGER OVERFLOW
30825             IF( AIX .GT. 1.D0.AND. AIX .LT. 11.D0.AND. AIY .GT. 1.D0.AND
30826      +      . AIY .LT. 102.D0) THEN
30827               IX=INT(AIX)
30828               IY=INT(AIY)
30829               IF( IX.GT. 0.AND. IX.LE. 10.AND. IY.GT. 0.AND. IY.LE. 101)
30830      +        THEN
30831                 IF(LL(IY,IX).NE.L(38).AND.LL(IY,IX).NE.L(39)) LOV(I,IX)
30832      +          =LL(IY,IX)
30833                 LL(IY,IX)=L(I)
30834               ENDIF
30835             ENDIF
30836    70   CONTINUE
30837 *
30838 *
30839         DO 80 I=1,10
30840           II=I+JJJ
30841           III=II+1
30842           WRITE(LOUT,510) XX(II),XX(III) , (LL(J,I),J=1,101) ,
30843      &                    (LOV(J,I),J=1,10)
30844    80   CONTINUE
30845    90 CONTINUE
30846 *
30847 *
30848       WRITE(LOUT, 520)
30849       WRITE(LOUT, 500) (YY(I),I=1,11)
30850       RETURN
30851 *
30852   500 FORMAT(11X,11(1PE10.2),11HOVERPRINTED)
30853   510 FORMAT(1X,2(1PE10.2),101A1,1H ,10A1)
30854   520 FORMAT(20X,10('1---------'),'1')
30855       END
30856 *$ CREATE DT_DEFSET.FOR
30857 *COPY DT_DEFSET
30858 *
30859 *===defset=============================================================*
30860 *
30861       BLOCK DATA DT_DEFSET
30862
30863       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30864       SAVE
30865
30866 * flags for input different options
30867       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
30868       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
30869      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
30870
30871       PARAMETER (NCOMPX=20,NEB=8,NQB= 5,KSITEB=50)
30872
30873 * emulsion treatment
30874       COMMON /DTCOMP/ EMUFRA(NCOMPX),IEMUMA(NCOMPX),IEMUCH(NCOMPX),
30875      &                NCOMPO,IEMUL
30876
30877 * / DTFLG1 /
30878       DATA IFRAG  / 2, 1 /
30879       DATA IRESCO / 1 /
30880       DATA IMSHL  / 1 /
30881       DATA IRESRJ / 0 /
30882       DATA IOULEV / -1, -1, -1, -1, -1, -1 /
30883       DATA LEMCCK / .FALSE. /
30884       DATA LHADRO / .FALSE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,.TRUE.,
30885      &              .TRUE.,.TRUE.,.TRUE./
30886       DATA LSEADI / .TRUE. /
30887       DATA LEVAPO / .TRUE. /
30888       DATA IFRAME / 1 /
30889       DATA ITRSPT / 0 /
30890
30891 * / DTCOMP /
30892       DATA EMUFRA / NCOMPX*0.0D0 /
30893       DATA IEMUMA / NCOMPX*1 /
30894       DATA IEMUCH / NCOMPX*1 /
30895       DATA NCOMPO / 0 /
30896       DATA IEMUL  / 0 /
30897
30898       END
30899
30900 *$ CREATE DT_HADPRP.FOR
30901 *COPY DT_HADPRP
30902 *
30903 *===hadprp=============================================================*
30904 *
30905       BLOCK DATA DT_HADPRP
30906
30907       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
30908       SAVE
30909
30910 * auxiliary common for reggeon exchange (DTUNUC 1.x)
30911       COMMON /DTQUAR/ IQECHR(-6:6),IQBCHR(-6:6),IQICHR(-6:6),
30912      &                IQSCHR(-6:6),IQCCHR(-6:6),IQUCHR(-6:6),
30913      &                IQTCHR(-6:6),MQUARK(3,39)
30914
30915 * hadron index conversion (BAMJET <--> PDG)
30916       COMMON /DTHAIC/ IPDG2(2,7),IBAM2(2,7),IPDG3(2,22),IBAM3(2,22),
30917      &                IPDG4(2,29),IBAM4(2,29),IPDG5(2,19),IBAM5(2,19),
30918      &                IAMCIN(210)
30919
30920 * names of hadrons used in input-cards
30921       CHARACTER*8 BTYPE
30922       COMMON /DTPAIN/ BTYPE(30)
30923
30924 * / DTQUAR /
30925 *----------------------------------------------------------------------*
30926 *                                                                      *
30927 *     Quark content of particles:                                      *
30928 *          index   quark   el. charge  bar. charge  isospin  isospin3  *
30929 *              1 = u          2/3          1/3        1/2       1/2    *
30930 *             -1 = ubar      -2/3         -1/3        1/2      -1/2    *
30931 *              2 = d         -1/3          1/3        1/2      -1/2    *
30932 *             -2 = dbar       1/3         -1/3        1/2       1/2    *
30933 *              3 = s         -1/3          1/3         0         0     *
30934 *             -3 = sbar       1/3         -1/3         0         0     *
30935 *              4 = c          2/3          1/3         0         0     *
30936 *             -4 = cbar      -2/3         -1/3         0         0     *
30937 *              5 = b         -1/3          1/3         0         0     *
30938 *             -5 = bbar       1/3         -1/3         0         0     *
30939 *              6 = t          2/3          1/3         0         0     *
30940 *             -6 = tbar      -2/3         -1/3         0         0     *
30941 *                                                                      *
30942 *         Mquark = particle quark composition (Paprop numbering)       *
30943 *         Iqechr = electric charge ( in 1/3 unit )                     *
30944 *         Iqbchr = baryonic charge ( in 1/3 unit )                     *
30945 *         Iqichr = isospin ( in 1/2 unit ), z component                *
30946 *         Iqschr = strangeness                                         *
30947 *         Iqcchr = charm                                               *
30948 *         Iquchr = beauty                                              *
30949 *         Iqtchr = ......                                              *
30950 *                                                                      *
30951 *----------------------------------------------------------------------*
30952       DATA IQECHR / -2, 1, -2, 1, 1, -2, 0, 2, -1, -1, 2, -1, 2 /
30953       DATA IQBCHR / 6*-1, 0, 6*1 /
30954       DATA IQICHR / 4*0, 1, -1, 0, 1, -1, 4*0 /
30955       DATA IQSCHR / 3*0, 1, 5*0, -1, 3*0 /
30956       DATA IQCCHR / 2*0, -1, 7*0, 1, 2*0 /
30957       DATA IQUCHR / 0, 1, 9*0, -1, 0 /
30958       DATA IQTCHR / -1, 11*0, 1 /
30959       DATA MQUARK /
30960      &   2, 1, 1,   -2,-1,-1,    0, 0, 0,    0, 0, 0,    0, 0, 0,
30961      &   0, 0, 0,    0, 0, 0,    2, 2, 1,   -2,-2,-1,    0, 0, 0,
30962      &   0, 0, 0,    0, 0, 0,    1,-2, 0,    2,-1, 0,    1,-3, 0,
30963      &   3,-1, 0,    1, 2, 3,   -1,-2,-3,    0, 0, 0,    2, 2, 3,
30964      &   1, 1, 3,    1, 2, 3,    1,-1, 0,    2,-3, 0,    3,-2, 0,
30965      &   2,-2, 0,    3,-3, 0,    0, 0, 0,    0, 0, 0,    0, 0, 0,
30966      &  -1,-1,-3,   -1,-2,-3,   -2,-2,-3,    1, 3, 3,   -1,-3,-3,
30967      &   2, 3, 3,   -2,-3,-3,    3, 3, 3,   -3,-3,-3 /
30968
30969 * / DTHAIC /
30970 * (renamed) (HAdron InDex COnversion)
30971 * translation table version filled up by r.e. 25.01.94                 *
30972       DATA IAMCIN /
30973      &2212,-2212,11,-11,12,              -12,22,2112,-2112,-13,
30974      &13,130,211,-211,321,               -321,3122,-3122,310,3112,
30975      &3222,3212,111,311,-311,            0,0,0,0,0,
30976      &221,213,113,-213,223,              323,313,-323,-313,10323,
30977      &10313,-10323,-10313,30323,30313,   -30323,-30313,3224,3214,3114,
30978      &3216,3218,2224,2214,2114,          1114,12224,12214,12114,11114,
30979      &99999,99999,22212,22112,32124,     31214,-2224,-2214,-2114,-1114,
30980      &-12224,-12214,-12114,-11114,-2124, -1214,4*99999,
30981      &5*99999,                           5*99999,
30982      &4*99999,331,                       333,3322,3312,-3222,-3212,
30983      &-3112,-3322,-3312,3224,3214,       3114,3324,3314,3334,-3224,
30984      &-3214,-3114,-3324,-3314,-3334,     421,411,-411,-421,431,
30985      &-431,441,423,413,-413,             -423,433,-433,20443,443,
30986      &-15,15,16,-16,14,                  -14,4122,4232,4132,4222,
30987      &4212,4112,3*99999,                 3*99999,-4122,-4232,
30988      &-4132,-4222,-4212,-4112,99999,     5*99999,
30989      &5*99999,                           5*99999,
30990      &10*99999,
30991      &5*99999 , 20211,20111,-20211,99999,20321,
30992      &-20321,20311,-20311,7*99999 ,
30993      &7*99999,12212,12112,99999/
30994
30995 * / DTHAIC /
30996 * (HAdron InDex COnversion)
30997       DATA (IPDG2(1,K),K=1,7)
30998      &   /   -11,   -12,   -13,   -15,   -16,   -14,     0/
30999       DATA (IBAM2(1,K),K=1,7)
31000      &   /     4,     6,    10,   131,   134,   136,     0/
31001       DATA (IPDG2(2,K),K=1,7)
31002      &   /    11,    12,    22,    13,    15,    16,    14/
31003       DATA (IBAM2(2,K),K=1,7)
31004      &   /     3,     5,     7,    11,   132,   133,   135/
31005       DATA (IPDG3(1,K),K=1,22)
31006      &   /  -211,  -321,  -311,  -213,  -323,  -313,  -411,  -421,
31007      &      -431,  -413,  -423,  -433,     0,     0,     0,     0,
31008      &         0,     0,     0,     0,     0,     0/
31009       DATA (IBAM3(1,K),K=1,22)
31010      &   /    14,    16,    25,    34,    38,    39,   118,   119,
31011      &       121,   125,   126,   128,     0,     0,     0,     0,
31012      &         0,     0,     0,     0,     0,     0/
31013       DATA (IPDG3(2,K),K=1,22)
31014      &   /   130,   211,   321,   310,   111,   311,   221,   213,
31015      &       113,   223,   323,   313,   331,   333,   421,   411,
31016      &       431,   441,   423,   413,   433,   443/
31017       DATA (IBAM3(2,K),K=1,22)
31018      &   /    12,    13,    15,    19,    23,    24,    31,    32,
31019      &        33,    35,    36,    37,    95,    96,   116,   117,
31020      &       120,   122,   123,   124,   127,   130/
31021       DATA (IPDG4(1,K),K=1,29)
31022      &   / -2212, -2112, -3122, -2224, -2214, -2114, -1114, -2124,
31023      &     -1214, -3222, -3212, -3112, -3322, -3312, -3224, -3214,
31024      &     -3114, -3324, -3314, -3334, -4122, -4232, -4132, -4222,
31025      &     -4212, -4112,     0,     0,     0/
31026       DATA (IBAM4(1,K),K=1,29)
31027      &   /     2,     9,    18,    67,    68,    69,    70,    75,
31028      &        76,    99,   100,   101,   102,   103,   110,   111,
31029      &       112,   113,   114,   115,   149,   150,   151,   152,
31030      &       153,   154,     0,     0,     0/
31031       DATA (IPDG4(2,K),K=1,29)
31032      &   /  2212,  2112,  3122,  3112,  3222,  3212,  3224,  3214,
31033      &      3114,  3216,  3218,  2224,  2214,  2114,  1114,  3322,
31034      &      3312,  3224,  3214,  3114,  3324,  3314,  3334,  4122,
31035      &      4232,  4132,  4222,  4212,  4112/
31036       DATA (IBAM4(2,K),K=1,29)
31037      &   /     1,     8,    17,    20,    21,    22,    48,    49,
31038      &        50,    51,    52,    53,    54,    55,    56,    97,
31039      &        98,   104,   105,   106,   107,   108,   109,   137,
31040      &       138,   139,   140,   141,   142/
31041       DATA (IPDG5(1,K),K=1,19)
31042      &   /-10323,-10313,-30323,-30313,-12224,-12214,-12114,-11114,
31043      &    -20211,-20321,-20311,     0,     0,     0,     0,     0,
31044      &         0,     0,     0/
31045       DATA (IBAM5(1,K),K=1,19)
31046      &   /    42,    43,    46,    47,    71,    72,    73,    74,
31047      &       188,   191,   193,     0,     0,     0,     0,     0,
31048      &         0,     0,     0/
31049       DATA (IPDG5(2,K),K=1,19)
31050      &   / 10323, 10313, 30323, 30313, 12224, 12214, 12114, 11114,
31051      &     22212, 22112, 32124, 31214, 20443, 20211, 20111, 20321,
31052      &     20311, 12212, 12112/
31053       DATA (IBAM5(2,K),K=1,19)
31054      &   /    40,    41,    44,    45,    57,    58,    59,    60,
31055      &        63,    64,    65,    66,   129,   186,   187,   190,
31056      &       192,   208,   209/
31057
31058 * / DTPAIN /
31059 * internal particle names
31060       DATA BTYPE / 'PROTON  ' , 'APROTON ' , 'ELECTRON' , 'POSITRON' ,
31061      &'NEUTRIE ' , 'ANEUTRIE' , 'PHOTON  ' , 'NEUTRON ' , 'ANEUTRON' ,
31062      &'MUON+   ' , 'MUON-   ' , 'KAONLONG' , 'PION+   ' , 'PION-   ' ,
31063      &'KAON+   ' , 'KAON-   ' , 'LAMBDA  ' , 'ALAMBDA ' , 'KAONSHRT' ,
31064      &'SIGMA-  ' , 'SIGMA+  ' , 'SIGMAZER' , 'PIZERO  ' , 'KAONZERO' ,
31065      &'AKAONZER' , 'NEUTRIM ' , 'ANEUTRIM' , 'NEUTRIT ' , 'ANEUTRIT' ,
31066      &'BLANK   ' /
31067
31068       END
31069
31070 *$ CREATE DT_BLKD46.FOR
31071 *COPY DT_BLKD46
31072 *
31073 *===blkd46=============================================================*
31074 *
31075       BLOCK DATA DT_BLKD46
31076
31077       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31078       SAVE
31079
31080       PARAMETER ( AMELCT = 0.51099906         D-03 )
31081       PARAMETER ( AMMUON = 0.105658389        D+00 )
31082
31083 * particle properties (BAMJET index convention)
31084       CHARACTER*8  ANAME
31085       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31086      &                IICH(210),IIBAR(210),K1(210),K2(210)
31087
31088 * / DTPART /
31089 * Particle  masses Engel version JETSET compatible
31090 C     DATA (AAM(K),K=1,85) /
31091 C    &   .9383D+00, .9383D+00,  AMELCT  ,  AMELCT  , .0000D+00,
31092 C    &   .0000D+00, .0000D+00, .9396D+00, .9396D+00, AMMUON   ,
31093 C    &   AMMUON   , .4977D+00, .1396D+00, .1396D+00, .4936D+00,
31094 C    &   .4936D+00, .1116D+01, .1116D+01, .4977D+00, .1197D+01,
31095 C    &   .1189D+01, .1193D+01, .1350D+00, .4977D+00, .4977D+00,
31096 C    &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31097 C    &   .5488D+00, .7669D+00, .7700D+00, .7669D+00, .7820D+00,
31098 C    &   .8921D+00, .8962D+00, .8921D+00, .8962D+00, .1300D+01,
31099 C    &   .1300D+01, .1300D+01, .1300D+01, .1421D+01, .1421D+01,
31100 C    &   .1421D+01, .1421D+01, .1383D+01, .1384D+01, .1387D+01,
31101 C    &   .1820D+01, .2030D+01, .1231D+01, .1232D+01, .1233D+01,
31102 C    &   .1234D+01, .1675D+01, .1675D+01, .1675D+01, .1675D+01,
31103 C    &   .1500D+01, .1500D+01, .1515D+01, .1515D+01, .1775D+01,
31104 C    &   .1775D+01, .1231D+01, .1232D+01, .1233D+01, .1234D+01,
31105 C    &   .1675D+01, .1675D+01, .1675D+01, .1675D+01, .1515D+01,
31106 C    &   .1515D+01, .2500D+01, .4890D+00, .4890D+00, .4890D+00,
31107 C    &   .1300D+01, .1300D+01, .1300D+01, .1300D+01, .2200D+01  /
31108 C     DATA (AAM(K),K=86,183) /
31109 C    &   .2200D+01, .2200D+01, .2200D+01, .1700D+01, .1700D+01,
31110 C    &   .1700D+01, .1700D+01, .1820D+01, .2030D+01, .9575D+00,
31111 C    &   .1019D+01, .1315D+01, .1321D+01, .1189D+01, .1193D+01,
31112 C    &   .1197D+01, .1315D+01, .1321D+01, .1383D+01, .1384D+01,
31113 C    &   .1387D+01, .1532D+01, .1535D+01, .1672D+01, .1383D+01,
31114 C    &   .1384D+01, .1387D+01, .1532D+01, .1535D+01, .1672D+01,
31115 C    &   .1865D+01, .1869D+01, .1869D+01, .1865D+01, .1969D+01,
31116 C    &   .1969D+01, .2980D+01, .2007D+01, .2010D+01, .2010D+01,
31117 C    &   .2007D+01, .2113D+01, .2113D+01, .3686D+01, .3097D+01,
31118 C    &   .1784D+01, .1784D+01, .0000D+00, .0000D+00, .0000D+00,
31119 C    &   .0000D+00, .2285D+01, .2460D+01, .2460D+01, .2452D+01,
31120 C    &   .2453D+01, .2454D+01, .2560D+01, .2560D+01, .2730D+01,
31121 C    &   .3610D+01, .3610D+01, .3790D+01, .2285D+01, .2460D+01,
31122 C    &   .2460D+01, .2452D+01, .2453D+01, .2454D+01, .2560D+01,
31123 C    &   .2560D+01, .2730D+01, .3610D+01, .3610D+01, .3790D+01,
31124 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31125 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31126 C    &   .2490D+01, .2490D+01, .2490D+01, .2610D+01, .2610D+01,
31127 C    &   .2770D+01, .3670D+01, .3670D+01, .3850D+01, .4890D+01,
31128 C    &   .1250D+01, .1250D+01, .1250D+01  /
31129 C     DATA (AAM ( I ), I = 184,210 ) /
31130 C    & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31131 C    & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31132 C    & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31133 C    & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31134 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31135 C    & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31136 C    & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31137 C    & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31138 C    & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31139 * sr 25.1.06: particle masses adjusted to Pythia
31140       DATA (AAM(K),K=1,85) /
31141      &   .938270E+00,.938270E+00, AMELCT    , AMELCT    ,.000000E+00,
31142      &   .000000E+00,.000000E+00,.939570E+00,.939570E+00, AMMUON    ,
31143      &    AMMUON    ,.497670E+00,.139570E+00,.139570E+00,.493600E+00,
31144      &   .493600E+00,.111568E+01,.111568E+01,.497670E+00,.119744E+01,
31145      &   .118937E+01,.119255E+01,.134980E+00,.497670E+00,.497670E+00,
31146      &     .0000D+00,  .0000D+00,  .0000D+00 , .0000D+00,  .0000D+00,
31147      &   .547450E+00,.766900E+00,.768500E+00,.766900E+00,.781940E+00,
31148      &   .891600E+00,.896100E+00,.891600E+00,.896100E+00,.129000E+01,
31149      &   .129000E+01,.129000E+01,.129000E+01,  .1421D+01,  .1421D+01,
31150      &     .1421D+01,  .1421D+01,.138280E+01,.138370E+01,.138720E+01,
31151      &     .1820D+01,  .2030D+01,  .1231D+01,  .1232D+01,  .1233D+01,
31152      &     .1234D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,
31153      &     .1500D+01,  .1500D+01,  .1515D+01,  .1515D+01,  .1775D+01,
31154      &     .1775D+01,  .1231D+01,  .1232D+01,  .1233D+01,  .1234D+01,
31155      &     .1675D+01,  .1675D+01,  .1675D+01,  .1675D+01,  .1515D+01,
31156      &     .1515D+01,  .2500D+01,  .4890D+00,  .4890D+00,  .4890D+00,
31157      &     .1300D+01,  .1300D+01,  .1300D+01,  .1300D+01,  .2200D+01  /
31158       DATA (AAM(K),K=86,183) /
31159      &     .2200D+01,  .2200D+01,  .2200D+01,  .1700D+01,  .1700D+01,
31160      &     .1700D+01,  .1700D+01,  .1820D+01,  .2030D+01,.957770E+00,
31161      &   .101940E+01,.131490E+01,.132130E+01,.118937E+01,.119255E+01,
31162      &   .119744E+01,.131490E+01,.132130E+01,.138280E+01,.138370E+01,
31163      &   .138720E+01,.153180E+01,  .1535D+01,.167245E+01,.138280E+01,
31164      &   .138370E+01,.138720E+01,.153180E+01,  .1535D+01,.167245E+01,
31165      &   .186450E+01,.186930E+01,.186930E+01,.186450E+01,.196850E+01,
31166      &   .196850E+01,.297980E+01,.200670E+01,  .2010D+01,  .2010D+01,
31167      &   .200670E+01,.211240E+01,.211240E+01,  .3686D+01,.309688E+01,
31168      &   .177700E+01,.177700E+01,  .0000D+00,  .0000D+00,  .0000D+00,
31169      &     .0000D+00,.228490E+01,.246560E+01,.247030E+01,.245290E+01,
31170      &   .245350E+01,.245210E+01,  .2560D+01,  .2560D+01,  .2730D+01,
31171      &     .3610D+01,  .3610D+01,  .3790D+01,.228490E+01,.246560E+01,
31172      &     .2460D+01,.245290E+01,.245350E+01,.245210E+01,  .2560D+01,
31173      &     .2560D+01,  .2730D+01,  .3610D+01,  .3610D+01,  .3790D+01,
31174      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31175      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31176      &     .2490D+01,  .2490D+01,  .2490D+01,  .2610D+01,  .2610D+01,
31177      &     .2770D+01,  .3670D+01,  .3670D+01,  .3850D+01,  .4890D+01,
31178      &     .1250D+01,  .1250D+01,  .1250D+01  /
31179       DATA (AAM ( I ), I = 184,210 ) /
31180      & 1.44000000000000D+00, 1.44000000000000D+00, 1.30000000000000D+00,
31181      & 1.30000000000000D+00, 1.30000000000000D+00, 1.40000000000000D+00,
31182      & 1.46000000000000D+00, 1.46000000000000D+00, 1.46000000000000D+00,
31183      & 1.46000000000000D+00, 1.60000000000000D+00, 1.60000000000000D+00,
31184      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31185      & 1.66000000000000D+00, 1.66000000000000D+00, 1.66000000000000D+00,
31186      & 1.95000000000000D+00, 1.95000000000000D+00, 1.95000000000000D+00,
31187      & 1.95000000000000D+00, 2.25000000000000D+00, 2.25000000000000D+00,
31188      & 1.44000000000000D+00, 1.44000000000000D+00, 0.00000000000000D+00/
31189 * Particle  mean lives
31190       DATA (TAU(K),K=1,183) /
31191      &   .1000D+19, .1000D+19, .1000D+19, .1000D+19, .1000D+19,
31192      &   .1000D+19, .1000D+19, .9180D+03, .9180D+03, .2200D-05,
31193      &   .2200D-05, .5200D-07, .2600D-07, .2600D-07, .1200D-07,
31194      &   .1200D-07, .2600D-09, .2600D-09, .9000D-10, .1500D-09,
31195      &   .8000D-10, .5000D-14, .8000D-16, .0000D+00, .0000D+00,
31196      &   70*.0000D+00,
31197      &   .0000D+00, .3000D-09, .1700D-09, .8000D-10, .1000D-13,
31198      &   .1500D-09, .3000D-09, .1700D-09, .0000D+00, .0000D+00,
31199      &   .0000D+00, .0000D+00, .0000D+00, .1000D-09, .0000D+00,
31200      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .1000D-09,
31201      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31202      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31203      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31204      &   .9000D-11, .9000D-11, .9000D-11, .9000D-11, .1000D+19,
31205      &   .1000D+19, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31206      &   40*.0000D+00,
31207      &   .0000D+00, .0000D+00, .0000D+00  /
31208       DATA ( TAU ( I ), I = 184,210 ) /
31209      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31210      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31211      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
31212      & 0.00000000000000D+00, 0.00000000000000D+00, 0.00000000000000D+00,
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 * Resonance width Gamma in GeV
31219       DATA (GA(K),K=  1,85) /
31220      &    30*.0000D+00,
31221      &   .8500D-06, .1520D+00, .1520D+00, .1520D+00, .1000D-01,
31222      &   .7900D-01, .7900D-01, .7900D-01, .7900D-01, .4500D+00,
31223      &   .4500D+00, .4500D+00, .4500D+00, .1080D+00, .1080D+00,
31224      &   .1080D+00, .1080D+00, .5000D-01, .5000D-01, .5000D-01,
31225      &   .8500D-01, .1800D+00, .1150D+00, .1150D+00, .1150D+00,
31226      &   .1150D+00, .2000D+00, .2000D+00, .2000D+00, .2000D+00,
31227      &   .2000D+00, .2000D+00, .1000D+00, .1000D+00, .2000D+00,
31228      &   .2000D+00, .1150D+00, .1150D+00, .1150D+00, .1150D+00,
31229      &   .2000D+00, .2000D+00, .2000D+00, .2000D+00, .1000D+00,
31230      &   .1000D+00, .2000D+00, .1000D+00, .1000D+00, .1000D+00,
31231      &   .1000D+00, .1000D+00, .1000D+00, .1000D+00, .2000D+00  /
31232       DATA (GA(K),K= 86,183) /
31233      &   .2000D+00, .2000D+00, .2000D+00, .1500D+00, .1500D+00,
31234      &   .1500D+00, .1500D+00, .8500D-01, .1800D+00, .2000D-02,
31235      &   .4000D-02, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31236      &   .0000D+00, .0000D+00, .0000D+00, .3400D-01, .3400D-01,
31237      &   .3600D-01, .9000D-02, .9000D-02, .0000D+00, .3400D-01,
31238      &   .3400D-01, .3600D-01, .9000D-02, .9000D-02, .0000D+00,
31239      &   .0000D+00, .0000D+00, .0000D+00, .0000D+00, .0000D+00,
31240      &   .0000D+00, .0000D+00, .5000D-02, .2000D-02, .2000D-02,
31241      &   .5000D-02, .2000D-02, .2000D-02, .2000D-03, .7000D-03,
31242      &   50*.0000D+00,
31243      &   .3000D+00, .3000D+00, .3000D+00  /
31244       DATA ( GA ( I ), I = 184,210 ) /
31245      & 2.00000000000000D-01, 2.00000000000000D-01, 3.00000000000000D-01,
31246      & 3.00000000000000D-01, 3.00000000000000D-01, 2.70000000000000D-01,
31247      & 2.50000000000000D-01, 2.50000000000000D-01, 2.50000000000000D-01,
31248      & 2.50000000000000D-01, 1.50000000000000D-01, 1.50000000000000D-01,
31249      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31250      & 1.00000000000000D-01, 1.00000000000000D-01, 1.00000000000000D-01,
31251      & 6.00000000000000D-02, 6.00000000000000D-02, 6.00000000000000D-02,
31252      & 6.00000000000000D-02, 5.50000000000000D-02, 5.50000000000000D-02,
31253      & 2.00000000000000D-01, 2.00000000000000D-01, 0.00000000000000D+00/
31254 * Particle  names
31255 * S+1385+Sigma+(1385)    L02030+Lambda0(2030)
31256 * Rho77=Rho(770) Om783=Omega(783) K*14=K*(1420) and so on
31257 * designation N*@@ means N*@1(@2)
31258       DATA (ANAME(K),K=1,85) /
31259      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31260      &  'ANUE    ','GAM     ','NEU     ','ANEU    ','MUE+    ',
31261      &  'MUE-    ','K0L     ','PI+     ','PI-     ','K+      ',
31262      &  'K-      ','LAM     ','ALAM    ','K0S     ','SIGM-   ',
31263      &  'SIGM+   ','SIGM0   ','PI0     ','K0      ','AK0     ',
31264      &  'BLANK   ','BLANK   ','BLANK   ','BLANK   ','BLANK   ',
31265      &  'ETA550  ','RHO+77  ','RHO077  ','RHO-77  ','OM0783  ',
31266      &  'K*+892  ','K*0892  ','K*-892  ','AK*089  ','KA+125  ',
31267      &  'KA0125  ','KA-125  ','AKA012  ','K*+142  ','K*0142  ',
31268      &  'K*-142  ','AK*014  ','S+1385  ','S01385  ','S-1385  ',
31269      &  'L01820  ','L02030  ','N*++12  ','N*+ 12  ','N*012   ',
31270      &  'N*-12   ','N*++16  ','N*+16   ','N*016   ','N*-16   ',
31271      &  'N*+14   ','N*014   ','N*+15   ','N*015   ','N*+18   ',
31272      &  'N*018   ','AN--12  ','AN*-12  ','AN*012  ','AN*+12  ',
31273      &  'AN--16  ','AN*-16  ','AN*016  ','AN*+16  ','AN*-15  ',
31274      &  'AN*015  ','DE*=24  ','RPI+49  ','RPI049  ','RPI-49  ',
31275      &  'PIN++   ','PIN+0   ','PIN+-   ','PIN-0   ','PPPI    ' /
31276       DATA (ANAME(K),K=86,183) /
31277      &  'PNPI    ','APPPI   ','APNPI   ','K+PPI   ','K-PPI   ',
31278      &  'K+NPI   ','K-NPI   ','S+1820  ','S-2030  ','ETA*    ',
31279      &  'PHI     ','TETA0   ','TETA-   ','ASIG-   ','ASIG0   ',
31280      &  'ASIG+   ','ATETA0  ','ATETA+  ','SIG*+   ','SIG*0   ',
31281      &  'SIG*-   ','TETA*0  ','TETA*   ','OMEGA-  ','ASIG*-  ',
31282      &  'ASIG*0  ','ASIG*+  ','ATET*0  ','ATET*+  ','OMEGA+  ',
31283      &  'D0      ','D+      ','D-      ','AD0     ','F+      ',
31284      &  'F-      ','ETAC    ','D*0     ','D*+     ','D*-     ',
31285      &  'AD*0    ','F*+     ','F*-     ','PSI     ','JPSI    ',
31286      &  'TAU+    ','TAU-    ','NUET    ','ANUET   ','NUEM    ',
31287      &  'ANUEM   ','C0+     ','A+      ','A0      ','C1++    ',
31288      &  'C1+     ','C10     ','S+      ','S0      ','T0      ',
31289      &  'XU++    ','XD+     ','XS+     ','AC0-    ','AA-     ',
31290      &  'AA0     ','AC1--   ','AC1-    ','AC10    ','AS-     ',
31291      &  'AS0     ','AT0     ','AXU--   ','AXD-    ','AXS     ',
31292      &  'C1*++   ','C1*+    ','C1*0    ','S*+     ','S*0     ',
31293      &  'T*0     ','XU*++   ','XD*+    ','XS*+    ','TETA++  ',
31294      &  'AC1*--  ','AC1*-   ','AC1*0   ','AS*-    ','AS*0    ',
31295      &  'AT*0    ','AXU*--  ','AXD*-   ','AXS*-   ','ATET--  ',
31296      &  'RO      ','R+      ','R-      '  /
31297       DATA (    ANAME ( I ), I = 184,210 ) /
31298      &'AN*-14  ','AN*014  ','PI+130  ','PI0130  ','PI-130  ','F01400  ',
31299      &'K*+146  ','K*-146  ','K*0146  ','AK0146  ','L01600  ','AL0160  ',
31300      &'S+1660  ','S01660  ','S-1660  ','AS-166  ','AS0166  ','AS+166  ',
31301      &'X01950  ','X-1950  ','AX0195  ','AX+195  ','OM-225  ','AOM+22  ',
31302      &'N*+14   ','N*014   ','BLANK   '/
31303 * Charge of particles and resonances
31304       DATA (IICH ( I ), I =   1,210 ) /
31305      &  1, -1, -1,  1,  0,  0,  0,  0,  0,  1, -1,  0,  1, -1,  1,
31306      & -1,  0,  0,  0, -1,  1,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31307      &  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0, -1,  0,  1,  0,
31308      & -1,  0,  1,  0, -1,  0,  0,  2,  1,  0, -1,  2,  1,  0, -1,
31309      &  1,  0,  1,  0,  1,  0, -2, -1,  0,  1, -2, -1,  0,  1, -1,
31310      &  0,  1,  1,  0, -1,  2,  1,  0, -1,  2,  1,  0, -1,  2,  0,
31311      &  1, -1,  1, -1,  0,  0,  0, -1, -1,  0,  1,  0,  1,  1,  0,
31312      & -1,  0, -1, -1, -1,  0,  1,  0,  1,  1,  0,  1, -1,  0,  1,
31313      & -1,  0,  0,  1, -1,  0,  1, -1,  0,  0,  1, -1,  0,  0,  0,
31314      &  0,  1,  1,  0,  2,  1,  0,  1,  0,  0,  2,  1,  1, -1, -1,
31315      &  0, -2, -1,  0, -1,  0,  0, -2, -1, -1,  2,  1,  0,  1,  0,
31316      &  0,  2,  1,  1,  2, -2, -1,  0, -1,  0,  0, -2, -1, -1, -2,
31317      &  0,  1, -1, -1,  0,  1,  0, -1,  0,  1, -1,  0,  0,  0,  0,
31318      &  1,  0, -1, -1,  0,  1,  0, -1,  0,  1, -1,  1,  1,  0,  0/
31319 * Particle  baryonic charges
31320       DATA (IIBAR ( I ), I =   1,210 ) /
31321      &  1, -1,  0,  0,  0,  0,  0,  1, -1,  0,  0,  0,  0,  0,  0,
31322      &  0,  1, -1,  0,  1,  1,  1,  0,  0,  0,  0,  0,  0,  0,  0,
31323      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31324      &  0,  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
31325      &  1,  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31326      & -1,  2,  0,  0,  0,  1,  1,  1,  1,  2,  2,  0,  0,  1,  1,
31327      &  1,  1,  1,  1,  0,  0,  1,  1, -1, -1, -1, -1, -1,  1,  1,
31328      &  1,  1,  1,  1, -1, -1, -1, -1, -1, -1,  0,  0,  0,  0,  0,
31329      &  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
31330      &  0,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,  1, -1, -1,
31331      & -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,  1,  1,  1,  1,  1,
31332      &  1,  1,  1,  1,  1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
31333      &  0,  0,  0, -1, -1,  0,  0,  0,  0,  0,  0,  0,  0,  1, -1,
31334      &  1,  1,  1, -1, -1, -1,  1,  1, -1, -1,  1, -1,  1,  1,  0/
31335 * First number of decay channels used for resonances
31336 * and decaying particles
31337       DATA K1/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 16, 17,
31338      &  18, 24, 30, 34, 38, 40, 41, 43, 44, 136, 138, 330, 327, 328,
31339      &   2*330, 46, 51, 52, 54, 55, 58,
31340 *                                                             50
31341      &  60, 62, 64, 66, 68, 70, 72, 74, 82, 90, 98, 106, 109, 112, 114,
31342      & 123, 140, 141, 143, 145, 146, 150, 157, 164, 168, 174, 180, 187,
31343      & 194, 202, 210, 211, 213, 215, 216, 220, 227, 234, 238, 245, 252,
31344 *                                         85
31345      & 254, 255, 256, 257, 259, 262, 265, 267, 269, 272, 276, 279, 282,
31346      & 286, 290, 293, 299, 331, 335, 339, 340, 341, 343, 344, 345, 346,
31347      & 347, 350, 353, 356, 358, 360, 363, 366, 369, 372, 374, 376, 379,
31348      & 383, 385, 387, 391, 394, 397, 400, 402, 405, 408, 410, 412, 414,
31349      & 417, 420, 425, 430, 431, 432, 433, 434, 448, 452, 457, 458, 459,
31350      & 460, 461, 462, 466, 468, 470, 472, 486, 490, 495, 496, 497, 498,
31351      & 499, 500, 504, 506, 508, 510, 511, 512, 513, 514, 515, 516, 517,
31352      & 518, 519, 522, 523, 524, 525, 526, 527, 528, 529, 530, 531, 534,
31353      & 537, 539, 541, 547, 553, 558, 563, 568, 572, 573, 574, 575, 576,
31354      & 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588, 589,
31355      & 590, 596, 602 /
31356 * Last number of decay channels used for resonances
31357 * and decaying particles
31358       DATA K2/   1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 15, 16, 17,
31359      & 23, 29, 31, 35, 39, 40, 42, 43, 45, 137, 139, 330, 327, 328,
31360      & 2* 330, 50, 51, 53, 54, 57,
31361 *                                                                 50
31362      & 59, 61, 63, 65, 67, 69, 71, 73, 81, 89, 97, 105, 108, 111, 113,
31363      & 122, 135, 140, 142, 144, 145, 149, 156, 163, 167, 173, 179, 186,
31364      & 193, 201, 209, 210, 212, 214, 215, 219, 226, 233, 237, 244, 251,
31365 *                                              85
31366      & 253, 254, 255, 256, 258, 261, 264, 266, 268, 271, 275, 278, 281,
31367      & 285, 289, 292, 298, 307, 334, 338, 339, 340, 342, 343, 344, 345,
31368      & 346, 349, 352, 355, 357, 359, 362, 365, 368, 371, 373, 375, 378,
31369      & 382, 384, 386, 390, 393, 396, 399, 401, 404, 407, 409, 411, 413,
31370      & 416, 419, 424, 429, 430, 431, 432, 433, 447, 451, 456, 457, 458,
31371      & 459, 460, 461, 465, 467, 469, 471, 485, 489, 494, 495, 496, 497,
31372      & 498, 499, 503, 505, 507, 509, 510, 511, 512, 513, 514, 515, 516,
31373      & 517, 518, 521, 522, 523, 524, 525, 526, 527, 528, 529, 530, 533,
31374      & 536, 538, 540, 546, 552, 557, 562, 567, 571, 572, 573, 574, 575,
31375      & 576, 577, 578, 579, 580, 581, 582, 583, 584, 585, 586, 587, 588,
31376      & 589, 595, 601, 602 /
31377
31378        END
31379
31380 *$ CREATE DT_BLKD47.FOR
31381 *COPY DT_BLKD47
31382 *
31383 *===blkd47=============================================================*
31384 *
31385       BLOCK DATA DT_BLKD47
31386
31387       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31388       SAVE
31389
31390 * HADRIN: decay channel information
31391       PARAMETER (IDMAX9=602)
31392       CHARACTER*8 ZKNAME
31393       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
31394
31395 * Name of decay channel
31396 * Designation N*@ means N*@1(1236)
31397 * @1=# means ++,  @1 = = means --
31398 * Designation  P+/0/- means Pi+/Pi0/Pi- , respectively
31399       DATA (ZKNAME(K),K=  1, 85) /
31400      &  'P       ','AP      ','E-      ','E+      ','NUE     ',
31401      &  'ANUE    ','GAM     ','PE-NUE  ','APEANU  ','EANUNU  ',
31402      &  'E-NUAN  ','3PI0    ','PI+-0   ','PIMUNU  ','PIE-NU  ',
31403      &  'MU+NUE  ','MU-NUE  ','MU+NUE  ','PI+PI0  ','PI++-   ',
31404      &  'PI+00   ','M+P0NU  ','E+P0NU  ','MU-NU   ','PI-0    ',
31405      &  'PI+--   ','PI-00   ','M-P0NU  ','E-P0NU  ','PPI-    ',
31406      &  'NPI0    ','PD-NUE  ','PM-NUE  ','APPI+   ','ANPI0   ',
31407      &  'APE+NU  ','APM+NU  ','PI+PI-  ','PI0PI0  ','NPI-    ',
31408      &  'PPI0    ','NPI+    ','LAGA    ','GAGA    ','GAE+E-  ',
31409      &  'GAGA    ','GAGAP0  ','PI000   ','PI+-0   ','PI+-GA  ',
31410      &  'PI+0    ','PI+-    ','PI00    ','PI-0    ','PI+-0   ',
31411      &  'PI+-    ','PI0GA   ','K+PI0   ','K0PI+   ','KOPI0   ',
31412      &  'K+PI-   ','K-PI0   ','AK0PI-  ','AK0PI0  ','K-PI+   ',
31413      &  'K+PI0   ','K0PI+   ','K0PI0   ','K+PI-   ','K-PI0   ',
31414      &  'K0PI-   ','AK0PI0  ','K-PI+   ','K+PI0   ','K0PI+   ',
31415      &  'K+89P0  ','K08PI+  ','K+RO77  ','K0RO+7  ','K+OM07  ',
31416      &  'K+E055  ','K0PI0   ','K+PI+   ','K089P0  ','K+8PI-  '  /
31417       DATA (ZKNAME(K),K= 86,170) /
31418      &  'K0R077  ','K+R-77  ','K+R-77  ','K0OM07  ','K0E055  ',
31419      &  'K-PI0   ','K0PI-   ','K-89P0  ','AK08P-  ','K-R077  ',
31420      &  'AK0R-7  ','K-OM07  ','K-E055  ','AK0PI0  ','K-PI+   ',
31421      &  'AK08P0  ','K-8PI+  ','AK0R07  ','AK0OM7  ','AK0E05  ',
31422      &  'LA0PI+  ','SI0PI+  ','SI+PI0  ','LA0PI0  ','SI+PI-  ',
31423      &  'SI-PI+  ','LA0PI-  ','SI0PI-  ','NEUAK0  ','PK-     ',
31424      &  'SI+PI-  ','SI0PI0  ','SI-PI+  ','LA0ET0  ','S+1PI-  ',
31425      &  'S-1PI+  ','SO1PI0  ','NEUAK0  ','PK-     ','LA0PI0  ',
31426      &  'LA0OM0  ','LA0RO0  ','SI+RO-  ','SI-RO+  ','SI0RO0  ',
31427      &  'LA0ET0  ','SI0ET0  ','SI+PI-  ','SI-PI+  ','SI0PI0  ',
31428      &  'K0S     ','K0L     ','K0S     ','K0L     ','P PI+   ',
31429      &  'P PI0   ','N PI+   ','P PI-   ','N PI0   ','N PI-   ',
31430      &  'P PI+   ','N*#PI0  ','N*+PI+  ','PRHO+   ','P PI0   ',
31431      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31432      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31433      &  'N*-PI+  ','PRHO-   ','NRHO0   ','N PI-   ','N*0PI-  ',
31434      &  'N*-PI0  ','NRHO-   ','PETA0   ','N*#PI-  ','N*+PI0  '  /
31435       DATA (ZKNAME(K),K=171,255) /
31436      &  'N*0PI+  ','PRHO0   ','NRHO+   ','NETA0   ','N*+PI-  ',
31437      &  'N*0PI0  ','N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ',
31438      &  'N PI+   ','N*#PI-  ','N*+PI0  ','N*0PI+  ','PRHO0   ',
31439      &  'NRHO+   ','P PI-   ','N PI0   ','N*+PI-  ','N*0PI0  ',
31440      &  'N*-PI+  ','PRHO-   ','NRHO0   ','P PI0   ','N PI+   ',
31441      &  'PRHO0   ','NRHO+   ','LAMK+   ','S+ K0   ','S0 K+   ',
31442      &  'PETA0   ','P PI-   ','N PI0   ','PRHO-   ','NRHO0   ',
31443      &  'LAMK0   ','S0 K0   ','S- K+   ','NETA/   ','APPI-   ',
31444      &  'APPI0   ','ANPI-   ','APPI+   ','ANPI0   ','ANPI+   ',
31445      &  'APPI-   ','AN*=P0  ','AN*-P-  ','APRHO-  ','APPI0   ',
31446      &  'ANPI-   ','AN*=P+  ','AN*-P0  ','AN*0P-  ','APRHO0  ',
31447      &  'ANRHO-  ','APPI+   ','ANPI0   ','AN*-P+  ','AN*0P0  ',
31448      &  'AN*+P-  ','APRHO+  ','ANRHO0  ','ANPI+   ','AN*0P+  ',
31449      &  'AN*+P0  ','ANRHO+  ','APPI0   ','ANPI-   ','AN*=P+  ',
31450      &  'AN*-P0  ','AN*0P-  ','APRHO0  ','ANRHO-  ','APPI+,  ',
31451      &  'ANPI0   ','AN*-P+  ','AN*0P0  ','AN*+P-  ','APRHO+  ',
31452      &  'ANRHO0  ','PN*014  ','NN*=14  ','PI+0    ','PI+-    '  /
31453       DATA (ZKNAME(K),K=256,340) /
31454      &  'PI-0    ','P+0     ','N++     ','P+-     ','P00     ',
31455      &  'N+0     ','N+-     ','N00     ','P-0     ','N-0     ',
31456      &  'P--     ','PPPI0   ','PNPI+   ','PNPI0   ','PPPI-   ',
31457      &  'NNPI+   ','APPPI0  ','APNPI+  ','ANNPI0  ','ANPPI-  ',
31458      &  'APNPI0  ','APPPI-  ','ANNPI-  ','K+PPI0  ','K+NPI+  ',
31459      &  'K0PPI0  ','K-PPI0  ','K-NPI+  ','AKPPI-  ','AKNPI0  ',
31460      &  'K+NPI0  ','K+PPI-  ','K0PPI0  ','K0NPI+  ','K-NPI0  ',
31461      &  'K-PPI-  ','AKNPI-  ','PAK0    ','SI+PI0  ','SI0PI+  ',
31462      &  'SI+ETA  ','S+1PI0  ','S01PI+  ','NEUK-   ','LA0PI-  ',
31463      &  'SI-OM0  ','LA0RO-  ','SI0RO-  ','SI-RO0  ','SI-ET0  ',
31464      &  'SI0PI-  ','SI-0    ','BLANC   ','BLANC   ','BLANC   ',
31465      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31466      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31467      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31468      &  'BLANC   ','BLANC   ','BLANC   ','BLANC   ','BLANC   ',
31469      &  'EPI+-   ','EPI00   ','GAPI+-  ','GAGA*   ','K+-     ',
31470      &  'KLKS    ','PI+-0   ','EGA     ','LPI0    ','LPI     '  /
31471       DATA (ZKNAME(K),K=341,425) /
31472      &  'APPI0   ','ANPI-   ','ALAGA   ','ANPI    ','ALPI0   ',
31473      &  'ALPI+   ','LAPI+   ','SI+PI0  ','SI0PI+  ','LAPI0   ',
31474      &  'SI+PI-  ','SI-PI+  ','LAPI-   ','SI-PI0  ','SI0PI-  ',
31475      &  'TE0PI0  ','TE-PI+  ','TE0PI-  ','TE-PI0  ','TE0PI   ',
31476      &  'TE-PI   ','LAK-    ','ALPI-   ','AS-PI0  ','AS0PI-  ',
31477      &  'ALPI0   ','AS+PI-  ','AS-PI+  ','ALPI+   ','AS+PI0  ',
31478      &  'AS0PI+  ','AT0PI0  ','AT+PI-  ','AT0PI+  ','AT+PI0  ',
31479      &  'AT0PI   ','AT+PI   ','ALK+    ','K-PI+   ','K-PI+0  ',
31480      &  'K0PI+-  ','K0PI0   ','K-PI++  ','AK0PI+  ','K+PI--  ',
31481      &  'K0PI-   ','K+PI-   ','K+PI-0  ','AKPI-+  ','AK0PI0  ',
31482      &  'ETAPIF  ','K++-    ','K+AK0   ','ETAPI-  ','K--+    ',
31483      &  'K-K0    ','PI00    ','PI+-    ','GAGA    ','D0PI0   ',
31484      &  'D0GA    ','D0PI+   ','D+PI0   ','DFGA    ','AD0PI-  ',
31485      &  'D-PI0   ','D-GA    ','AD0PI0  ','AD0GA   ','F+GA    ',
31486      &  'F+GA    ','F-GA    ','F-GA    ','PSPI+-  ','PSPI00  ',
31487      &  'PSETA   ','E+E-    ','MUE+-   ','PI+-0   ','M+NN    ',
31488      &  'E+NN    ','RHO+NT  ','PI+ANT  ','K*+ANT  ','M-NN    '  /
31489       DATA (ZKNAME(K),K=426,510) /
31490      &  'E-NN    ','RHO-NT  ','PI-NT   ','K*-NT   ','NUET    ',
31491      &  'ANUET   ','NUEM    ','ANUEM   ','SI+ETA  ','SI+ET*  ',
31492      &  'PAK0    ','TET0K+  ','SI*+ET  ','N*+AK0  ','N*++K-  ',
31493      &  'LAMRO+  ','SI0RO+  ','SI+RO0  ','SI+OME  ','PAK*0   ',
31494      &  'N*+AK*  ','N*++K*  ','SI+AK0  ','TET0PI  ','SI+AK*  ',
31495      &  'TET0RO  ','SI0AK*  ','SI+K*-  ','TET0OM  ','TET-RO  ',
31496      &  'SI*0AK  ','C0+PI+  ','C0+PI0  ','C0+PI-  ','A+GAM   ',
31497      &  'A0GAM   ','TET0AK  ','TET0K*  ','OM-RO+  ','OM-PI+  ',
31498      &  'C1++AK  ','A+PI+   ','C0+AK0  ','A0PI+   ','A+AK0   ',
31499      &  'T0PI+   ','ASI-ET  ','ASI-E*  ','APK0    ','ATET0K  ',
31500      &  'ASI*-E  ','AN*-K0  ','AN*--K  ','ALAMRO  ','ASI0RO  ',
31501      &  'ASI-RO  ','ASI-OM  ','APK*0   ','AN*-K*  ','AN*--K  ',
31502      &  'ASI-K0  ','ATETPI  ','ASI-K*  ','ATETRO  ','ASI0K*  ',
31503      &  'ASI-K*  ','ATE0OM  ','ATE+RO  ','ASI*0K  ','AC-PI-  ',
31504      &  'AC-PI0  ','AC-PI+  ','AA-GAM  ','AA0GAM  ','ATET0K  ',
31505      &  'ATE0K*  ','AOM+RO  ','AOM+PI  ','AC1--K  ','AA-PI-  ',
31506      &  'AC0-K0  ','AA0PI-  ','AA-K0   ','AT0PI-  ','C1++GA  '  /
31507       DATA (ZKNAME(K),K=511,540) /
31508      &  'C1++GA  ','C10GAM  ','S+GAM   ','S0GAM   ','T0GAM   ',
31509      &  'XU++GA  ','XD+GAM  ','XS+GAM  ','A+AKPI  ','T02PI+  ',
31510      &  'C1++2K  ','AC1--G  ','AC1-GA  ','AC10GA  ','AS-GAM  ',
31511      &  'AS0GAM  ','AT0GAM  ','AXU--G  ','AXD-GA  ','AXS-GA  ',
31512      &  'AA-KPI  ','AT02PI  ','AC1--K  ','RH-PI+  ','RH+PI-  ',
31513      &  'RH3PI0  ','RH0PI+  ','RH+PI0  ','RH0PI-  ','RH-PI0  '  /
31514       DATA (ZKNAME(I),I=541,602)/
31515      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHO0','ANRHO-','ANETA ',
31516      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0','RH0PI+','RH+PI0',
31517      & '3PI+00','3PI-++','F0PI+ ','RH+PI-','RH0PI0','3PI000','3PI0+-',
31518      & 'F0PI0 ','RH0PI-','RH-PI0','3PI-00','3PI--+','F0PI- ','PI0PI0',
31519      & 'PI+PI-','K+K-  ','K0AK0 ','L01600','AL0160','K*+146','K*-146',
31520      & 'K*0146','AK0146','S+1660','S01660','S-1660','AS-166','AS0166',
31521      & 'AS+166','X01690','X-1690','AX0169','AX+169','OM-225','AOM+22',
31522      & 'N*PPI0','N*NPI+','N*P2P0','N*PP+-','N*D+P0','N*D0P+','N*NPI0',
31523      & 'N*PPI-','N*N2P0','N*NP+-','N*D+P-','N*D0P0','BLANK '/
31524 * Weight of decay channel
31525       DATA (WT(K),K=  1, 85) /
31526      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31527      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31528      &   .1000D+01, .2100D+00, .1200D+00, .2700D+00, .4000D+00,
31529      &   .1000D+01, .1000D+01, .6400D+00, .2100D+00, .6000D-01,
31530      &   .2000D-01, .3000D-01, .4000D-01, .6400D+00, .2100D+00,
31531      &   .6000D-01, .2000D-01, .3000D-01, .4000D-01, .6400D+00,
31532      &   .3600D+00, .0000D+00, .0000D+00, .6400D+00, .3600D+00,
31533      &   .0000D+00, .0000D+00, .6900D+00, .3100D+00, .1000D+01,
31534      &   .5200D+00, .4800D+00, .1000D+01, .9900D+00, .1000D-01,
31535      &   .3800D+00, .3000D-01, .3000D+00, .2400D+00, .5000D-01,
31536      &   .1000D+01, .1000D+01, .0000D+00, .1000D+01, .9000D+00,
31537      &   .1000D-01, .9000D-01, .3300D+00, .6700D+00, .3300D+00,
31538      &   .6700D+00, .3300D+00, .6700D+00, .3300D+00, .6700D+00,
31539      &   .3300D+00, .6700D+00, .3300D+00, .6700D+00, .3300D+00,
31540      &   .6700D+00, .3300D+00, .6700D+00, .1900D+00, .3800D+00,
31541      &   .9000D-01, .2000D+00, .3000D-01, .4000D-01, .5000D-01,
31542      &   .2000D-01, .1900D+00, .3800D+00, .9000D-01, .2000D+00  /
31543       DATA (WT(K),K= 86,170) /
31544      &   .3000D-01, .4000D-01, .5000D-01, .2000D-01, .1900D+00,
31545      &   .3800D+00, .9000D-01, .2000D+00, .3000D-01, .4000D-01,
31546      &   .5000D-01, .2000D-01, .1900D+00, .3800D+00, .9000D-01,
31547      &   .2000D+00, .3000D-01, .4000D-01, .5000D-01, .2000D-01,
31548      &   .8800D+00, .6000D-01, .6000D-01, .8800D+00, .6000D-01,
31549      &   .6000D-01, .8800D+00, .1200D+00, .1900D+00, .1900D+00,
31550      &   .1600D+00, .1600D+00, .1700D+00, .3000D-01, .3000D-01,
31551      &   .3000D-01, .4000D-01, .1000D+00, .1000D+00, .2000D+00,
31552      &   .1200D+00, .1000D+00, .4000D-01, .4000D-01, .5000D-01,
31553      &   .7500D-01, .7500D-01, .3000D-01, .3000D-01, .4000D-01,
31554      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01,
31555      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31556      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31557      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31558      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31559      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31560      &   .2700D+00, .3000D+00, .4000D+00, .2000D+00, .1250D+00  /
31561       DATA (WT(K),K=171,255) /
31562      &   .7500D-01, .7500D-01, .1250D+00, .4000D+00, .7500D-01,
31563      &   .1250D+00, .2000D+00, .1250D+00, .7500D-01, .1800D+00,
31564      &   .3700D+00, .1300D+00, .8000D-01, .4000D-01, .7000D-01,
31565      &   .1300D+00, .3700D+00, .1800D+00, .4000D-01, .8000D-01,
31566      &   .1300D+00, .1300D+00, .7000D-01, .7000D-01, .1300D+00,
31567      &   .2300D+00, .4700D+00, .5000D-01, .2000D-01, .1000D-01,
31568      &   .2000D-01, .1300D+00, .7000D-01, .4700D+00, .2300D+00,
31569      &   .5000D-01, .1000D-01, .2000D-01, .2000D-01, .1000D+01,
31570      &   .6700D+00, .3300D+00, .3300D+00, .6700D+00, .1000D+01,
31571      &   .2500D+00, .2700D+00, .1800D+00, .3000D+00, .1700D+00,
31572      &   .8000D-01, .1800D+00, .3000D-01, .2400D+00, .2000D+00,
31573      &   .1000D+00, .8000D-01, .1700D+00, .2400D+00, .3000D-01,
31574      &   .1800D+00, .1000D+00, .2000D+00, .2500D+00, .1800D+00,
31575      &   .2700D+00, .3000D+00, .1800D+00, .3700D+00, .1300D+00,
31576      &   .8000D-01, .4000D-01, .7000D-01, .1300D+00, .3700D+00,
31577      &   .1800D+00, .4000D-01, .8000D-01, .1300D+00, .1300D+00,
31578      &   .7000D-01, .5000D+00, .5000D+00, .1000D+01, .1000D+01  /
31579       DATA (WT(K),K=256,340) /
31580      &   .1000D+01, .8000D+00, .2000D+00, .6000D+00, .3000D+00,
31581      &   .1000D+00, .6000D+00, .3000D+00, .1000D+00, .8000D+00,
31582      &   .2000D+00, .3300D+00, .6700D+00, .6600D+00, .1700D+00,
31583      &   .1700D+00, .3200D+00, .1700D+00, .3200D+00, .1900D+00,
31584      &   .3300D+00, .3300D+00, .3400D+00, .3000D+00, .5000D-01,
31585      &   .6500D+00, .3800D+00, .1200D+00, .3800D+00, .1200D+00,
31586      &   .3800D+00, .1200D+00, .3800D+00, .1200D+00, .3000D+00,
31587      &   .5000D-01, .6500D+00, .3800D+00, .2500D+00, .2500D+00,
31588      &   .2000D-01, .5000D-01, .5000D-01, .2000D+00, .2000D+00,
31589      &   .1200D+00, .1000D+00, .7000D-01, .7000D-01, .1400D+00,
31590      &   .5000D-01, .5000D-01, .1000D+01, .1000D+01, .1000D+01,
31591      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31592      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31593      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31594      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31595      &   .4800D+00, .2400D+00, .2600D+00, .2000D-01, .4700D+00,
31596      &   .3500D+00, .1500D+00, .3000D-01, .1000D+01, .1000D+01  /
31597       DATA (WT(K),K=341,425) /
31598      &   .5200D+00, .4800D+00, .1000D+01, .1000D+01, .1000D+01,
31599      &   .1000D+01, .9000D+00, .5000D-01, .5000D-01, .9000D+00,
31600      &   .5000D-01, .5000D-01, .9000D+00, .5000D-01, .5000D-01,
31601      &   .3300D+00, .6700D+00, .6700D+00, .3300D+00, .2500D+00,
31602      &   .2500D+00, .5000D+00, .9000D+00, .5000D-01, .5000D-01,
31603      &   .9000D+00, .5000D-01, .5000D-01, .9000D+00, .5000D-01,
31604      &   .5000D-01, .3300D+00, .6700D+00, .6700D+00, .3300D+00,
31605      &   .2500D+00, .2500D+00, .5000D+00, .1000D+00, .5000D+00,
31606      &   .1600D+00, .2400D+00, .7000D+00, .3000D+00, .7000D+00,
31607      &   .3000D+00, .1000D+00, .5000D+00, .1600D+00, .2400D+00,
31608      &   .3000D+00, .4000D+00, .3000D+00, .3000D+00, .4000D+00,
31609      &   .3000D+00, .4900D+00, .4900D+00, .2000D-01, .5500D+00,
31610      &   .4500D+00, .6800D+00, .3000D+00, .2000D-01, .6800D+00,
31611      &   .3000D+00, .2000D-01, .5500D+00, .4500D+00, .9000D+00,
31612      &   .1000D+00, .9000D+00, .1000D+00, .6000D+00, .3000D+00,
31613      &   .1000D+00, .1000D+00, .1000D+00, .8000D+00, .2800D+00,
31614      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .2800D+00  /
31615       DATA (WT(K),K=426,510) /
31616      &   .2800D+00, .3500D+00, .7000D-01, .2000D-01, .1000D+01,
31617      &   .1000D+01, .1000D+01, .1000D+01, .2000D-01, .3000D-01,
31618      &   .7000D-01, .2000D-01, .2000D-01, .4000D-01, .1300D+00,
31619      &   .7000D-01, .6000D-01, .6000D-01, .2000D+00, .1400D+00,
31620      &   .4000D-01, .1000D+00, .2500D+00, .3000D-01, .3000D+00,
31621      &   .4200D+00, .2200D+00, .3500D+00, .1900D+00, .1600D+00,
31622      &   .8000D-01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31623      &   .1000D+01, .3700D+00, .2000D+00, .3600D+00, .7000D-01,
31624      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00,
31625      &   .5000D+00, .2000D-01, .3000D-01, .7000D-01, .2000D-01,
31626      &   .2000D-01, .4000D-01, .1300D+00, .7000D-01, .6000D-01,
31627      &   .6000D-01, .2000D+00, .1400D+00, .4000D-01, .1000D+00,
31628      &   .2500D+00, .3000D-01, .3000D+00, .4200D+00, .2200D+00,
31629      &   .3500D+00, .1900D+00, .1600D+00, .8000D-01, .1000D+01,
31630      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .3700D+00,
31631      &   .2000D+00, .3600D+00, .7000D-01, .5000D+00, .5000D+00,
31632      &   .5000D+00, .5000D+00, .5000D+00, .5000D+00, .1000D+01  /
31633       DATA (WT(K),K=511,540) /
31634      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31635      &   .1000D+01, .1000D+01, .1000D+01, .3000D+00, .3000D+00,
31636      &   .4000D+00, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31637      &   .1000D+01, .1000D+01, .1000D+01, .1000D+01, .1000D+01,
31638      &   .3000D+00, .3000D+00, .4000D+00, .3300D+00, .3300D+00,
31639      &   .3400D+00, .5000D+00, .5000D+00, .5000D+00, .5000D+00  /
31640 C
31641       DATA (WT(I),I=541,602) / .0D+00, .3334D+00, .2083D+00, 2*.125D+00,
31642      & .2083D+00, .0D+00, .125D+00, .2083D+00, .3334D+00, .2083D+00,
31643      & .125D+00,  0.2D+00, 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00,
31644      & 0.2D+00, 0.3D+00, 0.3D+00, 0.0D+00, 0.2D+00, 0.2D+00, 0.3D+00,
31645      & 0.3D+00, 0.0D+00, 0.31D+00, 0.62D+00, 0.035D+00, 0.035D+00,
31646      & 18*1.D+00, 0.5D+00, 0.16D+00, 2*0.12D+00, 2*0.05D+00, 0.5D+00,
31647      & 0.16D+00, 2*0.12D+00, 2*0.05D+00, 1.D+00 /
31648 * Particle numbers in decay channel
31649       DATA (NZK(K,1),K=  1,170) /
31650      &     1,   2,   3,   4,   5,   6,   7,   1,   2,   4,
31651      &     3,  23,  13,  13,  13,  10,  11,  10,  13,  13,
31652      &    13,  10,   4,  11,  14,  14,  14,  11,   3,   1,
31653      &     8,   1,   1,   2,   9,   2,   2,  13,  23,   8,
31654      &     1,   8,  17,   7,   7,   7,  23,  23,  13,  13,
31655      &    13,  13,  23,  14,  13,  13,  23,  15,  24,  24,
31656      &    15,  16,  25,  25,  16,  15,  24,  24,  15,  16,
31657      &    24,  25,  16,  15,  24,  36,  37,  15,  24,  15,
31658      &    15,  24,  15,  37,  36,  24,  15,  24,  24,  16,
31659      &    24,  38,  39,  16,  25,  16,  16,  25,  16,  39,
31660      &    38,  25,  16,  25,  25,  17,  22,  21,  17,  21,
31661      &    20,  17,  22,   8,   1,  21,  22,  20,  17,  48,
31662      &    50,  49,   8,   1,  17,  17,  17,  21,  20,  22,
31663      &    17,  22,  21,  20,  22,  19,  12,  19,  12,   1,
31664      &     1,   8,   1,   8,   8,   1,  53,  54,   1,   1,
31665      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31666      &    56,   1,   8,   8,  55,  56,   8,   1,  53,  54  /
31667       DATA (NZK(K,1),K=171,340) /
31668      &    55,   1,   8,   8,  54,  55,  56,   1,   8,   1,
31669      &     8,  53,  54,  55,   1,   8,   1,   8,  54,  55,
31670      &    56,   1,   8,   1,   8,   1,   8,  17,  21,  22,
31671      &     1,   1,   8,   1,   8,  17,  22,  20,   8,   2,
31672      &     2,   9,   2,   9,   9,   2,  67,  68,   2,   2,
31673      &     9,  67,  68,  69,   2,   9,   2,   9,  68,  69,
31674      &    70,   2,   9,   9,  69,  70,   9,   2,   9,  67,
31675      &    68,  69,   2,   9,   2,   9,  68,  69,  70,   2,
31676      &     9,   1,   8,  13,  13,  14,   1,   8,   1,   1,
31677      &     8,   8,   8,   1,   8,   1,   1,   1,   1,   1,
31678      &     8,   2,   2,   9,   9,   2,   2,   9,  15,  15,
31679      &    24,  16,  16,  25,  25,  15,  15,  24,  24,  16,
31680      &    16,  25,   1,  21,  22,  21,  48,  49,   8,  17,
31681      &    20,  17,  22,  20,  20,  22,  20,   0,   0,   0,
31682      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31683      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31684      &    31,  31,  13,   7,  15,  12,  13,  31,  17,  17  /
31685       DATA (NZK(K,1),K=341,510) /
31686      &     2,   9,  18,   9,  18,  18,  17,  21,  22,  17,
31687      &    21,  20,  17,  20,  22,  97,  98,  97,  98,  97,
31688      &    98,  17,  18,  99, 100,  18, 101,  99,  18, 101,
31689      &   100, 102, 103, 102, 103, 102, 103,  18,  16,  16,
31690      &    24,  24,  16,  25,  15,  24,  15,  15,  25,  25,
31691      &    31,  15,  15,  31,  16,  16,  23,  13,   7, 116,
31692      &   116, 116, 117, 117, 119, 118, 118, 119, 119, 120,
31693      &   120, 121, 121, 130, 130, 130,   4,  10,  13,  10,
31694      &     4,  32,  13,  36,  11,   3,  34,  14,  38, 133,
31695      &   134, 135, 136,  21,  21,   1,  97, 104,  54,  53,
31696      &    17,  22,  21,  21,   1,  54,  53,  21,  97,  21,
31697      &    97,  22,  21,  97,  98, 105, 137, 137, 137, 138,
31698      &   139,  97,  97, 109, 109, 140, 138, 137, 139, 138,
31699      &   145,  99,  99,   2, 102, 110,  68,  67,  18, 100,
31700      &    99,  99,   2,  68,  67,  99, 102,  99, 102, 100,
31701      &    99, 102, 103, 111, 149, 149, 149, 150, 151, 113,
31702      &   113, 115, 115, 152, 150, 149, 151, 150, 157, 140  /
31703       DATA (NZK(K,1),K=511,540) /
31704      &   141, 142, 143, 144, 145, 146, 147, 148, 138, 145,
31705      &   140, 152, 153, 154, 155, 156, 157, 158, 159, 160,
31706      &   150, 157, 152,  34,  32,  33,  33,  32,  33,  34  /
31707       DATA (NZK(I,1),I=541,602) /  2, 67, 68, 69,  2,  9,  9, 68, 69,
31708      & 70,  2,  9, 33, 32, 13, 14, 189, 32, 34, 23, 23, 189, 33, 34, 14,
31709      & 14, 189, 23, 13, 15, 24,  36,  38,  37,  39, 194, 195, 196, 197,
31710      & 198, 199, 200, 201, 202, 203, 204, 205, 206, 207, 1, 8, 1, 1, 54,
31711      & 55, 8, 1, 8, 8, 54, 55, 210/
31712       DATA (NZK(K,2),K=  1,170) /
31713      &     0,   0,   0,   0,   0,   0,   0,   3,   4,   6,
31714      &     5,  23,  14,  11,   3,   5,   5,   5,  23,  13,
31715      &    23,  23,  23,   5,  23,  13,  23,  23,  23,  14,
31716      &    23,   3,  11,  13,  23,   4,  10,  14,  23,  14,
31717      &    23,  13,   7,   7,   4,   7,   7,  23,  14,  14,
31718      &    23,  14,  23,  23,  14,  14,   7,  23,  13,  23,
31719      &    14,  23,  14,  23,  13,  23,  13,  23,  14,  23,
31720      &    14,  23,  13,  23,  13,  23,  13,  33,  32,  35,
31721      &    31,  23,  14,  23,  14,  33,  34,  35,  31,  23,
31722      &    14,  23,  14,  33,  34,  35,  31,  23,  13,  23,
31723      &    13,  33,  32,  35,  31,  13,  13,  23,  23,  14,
31724      &    13,  14,  14,  25,  16,  14,  23,  13,  31,  14,
31725      &    13,  23,  25,  16,  23,  35,  33,  34,  32,  33,
31726      &    31,  31,  14,  13,  23,   0,   0,   0,   0,  13,
31727      &    23,  13,  14,  23,  14,  13,  23,  13,  78,  23,
31728      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31729      &    13,  80,  79,  14,  14,  23,  80,  31,  14,  23  /
31730       DATA (NZK(K,2),K=171,340) /
31731      &    13,  79,  78,  31,  14,  23,  13,  80,  79,  23,
31732      &    13,  14,  23,  13,  79,  78,  14,  23,  14,  23,
31733      &    13,  80,  79,  23,  13,  33,  32,  15,  24,  15,
31734      &    31,  14,  23,  34,  33,  24,  24,  15,  31,  14,
31735      &    23,  14,  13,  23,  13,  14,  23,  14,  80,  23,
31736      &    14,  13,  23,  14,  79,  80,  13,  23,  13,  23,
31737      &    14,  78,  79,  13,  13,  23,  78,  23,  14,  13,
31738      &    23,  14,  79,  80,  13,  23,  13,  23,  14,  78,
31739      &    79,  62,  61,  23,  14,  23,  13,  13,  13,  23,
31740      &    13,  13,  23,  14,  14,  14,   1,   8,   8,   1,
31741      &     8,   1,   8,   8,   1,   8,   1,   8,   1,   8,
31742      &     1,   1,   8,   1,   8,   8,   1,   1,   8,   8,
31743      &     1,   8,  25,  23,  13,  31,  23,  13,  16,  14,
31744      &    35,  34,  34,  33,  31,  14,  23,   0,   0,   0,
31745      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31746      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31747      &    13,  23,  14,   7,  16,  19,  14,   7,  23,  14  /
31748       DATA (NZK(K,2),K=341,510) /
31749      &    23,  14,   7,  13,  23,  13,  13,  23,  13,  23,
31750      &    14,  13,  14,  23,  14,  23,  13,  14,  23,  14,
31751      &    23,  16,  14,  23,  14,  23,  14,  13,  13,  23,
31752      &    13,  23,  14,  13,  23,  13,  23,  15,  13,  13,
31753      &    13,  23,  13,  13,  14,  14,  14,  14,  14,  23,
31754      &    13,  16,  25,  14,  15,  24,  23,  14,   7,  23,
31755      &     7,  13,  23,   7,  14,  23,   7,  23,   7,   7,
31756      &     7,   7,   7,  13,  23,  31,   3,  11,  14, 135,
31757      &     5, 134, 134, 134, 136,   6, 133, 133, 133,   0,
31758      &     0,   0,   0,  31,  95,  25,  15,  31,  95,  16,
31759      &    32,  32,  33,  35,  39,  39,  38,  25,  13,  39,
31760      &    32,  39,  38,  35,  32,  39,  13,  23,  14,   7,
31761      &     7,  25,  37,  32,  13,  25,  13,  25,  13,  25,
31762      &    13,  31,  95,  24,  16,  31,  24,  15,  34,  34,
31763      &    33,  35,  37,  37,  36,  24,  14,  37,  34,  37,
31764      &    36,  35,  34,  37,  14,  23,  13,   7,   7,  24,
31765      &    39,  34,  14,  24,  14,  24,  14,  24,  14,   7  /
31766       DATA (NZK(K,2),K=511,540) /
31767      &     7,   7,   7,   7,   7,   7,   7,   7,  25,  13,
31768      &    25,   7,   7,   7,   7,   7,   7,   7,   7,   7,
31769      &    24,  14,  24,  13,  14,  23,  13,  23,  14,  23  /
31770       DATA (NZK(I,2),I=541,602) / 31, 13, 23, 14, 79, 80, 31, 13, 23,
31771      & 14, 78, 79, 13, 23, 23, 13, 13, 14, 13, 23, 13, 23, 14, 23, 23,
31772      & 14, 14, 23, 14, 16, 25,
31773      & 4*23, 14*0, 23, 13, 23, 13, 23, 13, 23, 14,
31774      & 23, 13, 14, 23,  0 /
31775       DATA (NZK(K,3),K=  1,170) /
31776      &     0,   0,   0,   0,   0,   0,   0,   5,   6,   5,
31777      &     6,  23,  23,   5,   5,   0,   0,   0,   0,  14,
31778      &    23,   5,   5,   0,   0,  14,  23,   5,   5,   0,
31779      &     0,   5,   5,   0,   0,   5,   5,   0,   0,   0,
31780      &     0,   0,   0,   0,   3,   0,   7,  23,  23,   7,
31781      &     0,   0,   0,   0,  23,   0,   0,   0,   0,   0,
31782      &     110*0   /
31783       DATA (NZK(K,3),K=171,340) /
31784      &     80*0,
31785      &     0,   0,   0,   0,   0,   0,  23,  13,  14,  23,
31786      &    23,  14,  23,  23,  23,  14,  23,  13,  23,  14,
31787      &    13,  23,  13,  23,  14,  23,  14,  14,  23,  13,
31788      &    13,  23,  13,  14,  23,  23,  14,  23,  13,  23,
31789      &    14,  14,   0,   0,   0,   0,   0,   0,   0,   0,
31790      &     30*0,
31791      &    14,  23,   7,   0,   0,   0,  23,   0,   0,   0  /
31792       DATA (NZK(K,3),K=341,510) /
31793      &     30*0,
31794      &     0,   0,   0,   0,   0,   0,   0,   0,   0,  23,
31795      &    14,   0,  13,   0,  14,   0,   0,  23,  13,   0,
31796      &     0,  15,   0,   0,  16,   0,   0,   0,   0,   0,
31797      &     0,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31798      &     0,   0,   0,  14,  23,   0,   0,   0,  23, 134,
31799      &   134,   0,   0,   0, 133, 133,   0,   0,   0,   0,
31800      &     80*0  /
31801       DATA (NZK(K,3),K=511,540) /
31802      &     0,   0,   0,   0,   0,   0,   0,   0,  13,  13,
31803      &    25,   0,   0,   0,   0,   0,   0,   0,   0,   0,
31804      &    14,  14,  24,   0,   0,   0,   0,   0,   0,   0  /
31805       DATA (NZK(I,3),I=541,602) / 12*0, 2*0, 23, 13, 0, 2*0, 23, 14, 0,
31806      & 2*0, 23, 13, 0, 4*0, 18*0, 2*0, 23, 14, 2*0, 2*0, 23, 14, 2*0, 0/
31807
31808       END
31809
31810 *$ CREATE DT_XHOINI.FOR
31811 *COPY DT_XHOINI
31812 *
31813 *====phoini============================================================*
31814 *
31815       SUBROUTINE DT_XHOINI
31816 C     SUBROUTINE DT_PHOINI
31817
31818       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31819       SAVE
31820
31821       PARAMETER ( LINP = 10 ,
31822      &            LOUT = 6 ,
31823      &            LDAT = 9 )
31824
31825       RETURN
31826       END
31827
31828 *$ CREATE DT_XVENTB.FOR
31829 *COPY DT_XVENTB
31830 *
31831 *====eventb============================================================*
31832 *
31833       SUBROUTINE DT_XVENTB(NCSY,IREJ)
31834 C     SUBROUTINE DT_EVENTB(NCSY,IREJ)
31835
31836       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31837       SAVE
31838
31839       PARAMETER ( LINP = 10 ,
31840      &            LOUT = 6 ,
31841      &            LDAT = 9 )
31842
31843       WRITE(LOUT,1000)
31844  1000 FORMAT(1X,'EVENTB:   PHOJET-package requested but not linked!')
31845       STOP
31846
31847       END
31848
31849 *$ CREATE DT_XVENT.FOR
31850 *COPY DT_XVENT
31851 *
31852 *===event==============================================================*
31853 *
31854       SUBROUTINE DT_XVENT(IDUM,PP,PT,DUM,IREJ)
31855 C     SUBROUTINE EVENT(IDUM,PP,PT,DUM,IREJ)
31856
31857       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31858       SAVE
31859
31860       DIMENSION PP(4),PT(4)
31861
31862       RETURN
31863       END
31864
31865 *$ CREATE DT_XOHISX.FOR
31866 *COPY DT_XOHISX
31867 *
31868 *===pohisx=============================================================*
31869 *
31870       SUBROUTINE DT_XOHISX(I,X)
31871 C     SUBROUTINE POHISX(I,X)
31872
31873       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31874       SAVE
31875
31876       RETURN
31877       END
31878
31879 *$ CREATE PHO_LHIST.FOR
31880 *COPY PHO_LHIST
31881 *
31882 *===poluhi=============================================================*
31883 *
31884       SUBROUTINE PHO_LHIST(I,X)
31885
31886 **
31887
31888       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31889       SAVE
31890
31891       RETURN
31892       END
31893
31894 *$ CREATE PDFSET.FOR
31895 *COPY PDFSET
31896 *
31897 C**********************************************************************
31898 C
31899 C   dummy subroutines, remove to link PDFLIB
31900 C
31901 C**********************************************************************
31902       SUBROUTINE PDFSET(PARAM,VALUE)
31903       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31904       DIMENSION PARAM(20),VALUE(20)
31905       CHARACTER*20 PARAM
31906       END
31907
31908 *$ CREATE STRUCTM.FOR
31909 *COPY STRUCTM
31910 *
31911       SUBROUTINE STRUCTM(XI,SCALE2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31912       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31913       END
31914
31915 *$ CREATE STRUCTP.FOR
31916 *COPY STRUCTP
31917 *
31918       SUBROUTINE STRUCTP(XI,SCALE2,P2,IP2,UV,DV,US,DS,SS,CS,BS,TS,GL)
31919       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31920       END
31921
31922 *$ CREATE DT_DIQBRK.FOR
31923 *COPY DT_DIQBRK
31924 *
31925 *===diqbrk=============================================================*
31926 *
31927       SUBROUTINE DT_XIQBRK
31928 C     SUBROUTINE DT_DIQBRK
31929
31930       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31931       SAVE
31932
31933       STOP 'diquark-breaking not implemeted !'
31934
31935       RETURN
31936       END
31937 *$ CREATE DT_ELHAIN.FOR
31938 *COPY DT_ELHAIN
31939 *
31940 *===elhain=============================================================*
31941 *
31942       SUBROUTINE DT_ELHAIN(IP,PLA,ELAB,CX,CY,CZ,IT,IREJ)
31943
31944 ************************************************************************
31945 * Elastic hadron-hadron scattering.                                    *
31946 * This is a revised version of the original.                           *
31947 * This version dated 03.04.98 is written by S. Roesler                 *
31948 ************************************************************************
31949
31950       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
31951       SAVE
31952
31953       PARAMETER ( LINP = 10 ,
31954      &            LOUT = 6 ,
31955      &            LDAT = 9 )
31956
31957       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
31958      &           TINY10=1.0D-10)
31959
31960       PARAMETER (ENNTHR = 3.5D0)
31961       PARAMETER (PLOWH=0.01D0,PHIH=9.0D0,
31962      &           BLOWB=0.05D0,BHIB=0.2D0,
31963      &           BLOWM=0.1D0, BHIM=2.0D0)
31964
31965 * particle properties (BAMJET index convention)
31966       CHARACTER*8  ANAME
31967       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
31968      &                IICH(210),IIBAR(210),K1(210),K2(210)
31969
31970 * final state from HADRIN interaction
31971       PARAMETER (MAXFIN=10)
31972       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
31973      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
31974
31975 C     DATA TSLOPE /10.0D0/
31976
31977       IREJ = 0
31978
31979     1 CONTINUE
31980
31981       PLAB = SQRT( (ELAB-AAM(IP))*(ELAB+AAM(IP)) )
31982       EKIN = ELAB-AAM(IP)
31983 *   kinematical quantities in cms of the hadrons
31984       AMP2 = AAM(IP)**2
31985       AMT2 = AAM(IT)**2
31986       S    = AMP2+AMT2+TWO*ELAB*AAM(IT)
31987       ECM  = SQRT(S)
31988       ECMP = OHALF*ECM+(AMP2-AMT2)/(TWO*ECM)
31989       PCM  = SQRT( (ECMP-AAM(IP))*(ECMP+AAM(IP)) )
31990
31991 * nucleon-nucleon scattering at E_kin<3.5: use DT_TSAMCS(HETC-KFA)
31992       IF ( ((IP.EQ.1).OR.(IP.EQ.8)).AND.
31993      &     ((IT.EQ.1).OR.(IT.EQ.8)).AND.(EKIN.LT.ENNTHR) ) THEN
31994 *   TSAMCS treats pp and np only, therefore change pn into np and
31995 *   nn into pp
31996          IF (IT.EQ.1) THEN
31997             KPROJ = IP
31998          ELSE
31999             KPROJ = 8
32000             IF (IP.EQ.8) KPROJ = 1
32001          ENDIF
32002          CALL DT_TSAMCS(KPROJ,EKIN,CTCMS)
32003          T = TWO*PCM**2*(CTCMS-ONE)
32004
32005 * very crude treatment otherwise: sample t from exponential dist.
32006       ELSE
32007 *   momentum transfer t
32008          TMAX = TWO*TWO*PCM**2
32009          RR = (PLAB-PLOWH)/(PHIH-PLOWH)
32010          IF (IIBAR(IP).NE.0) THEN
32011             TSLOPE = BLOWB+RR*(BHIB-BLOWB)
32012          ELSE
32013             TSLOPE = BLOWM+RR*(BHIM-BLOWM)
32014          ENDIF
32015          FMAX = EXP(-TSLOPE*TMAX)-ONE
32016          R = DT_RNDM(RR)
32017          T = LOG(ONE+R*FMAX+TINY10)/TSLOPE
32018          IF (T.GT.ZERO) T = LOG(ONE+R*FMAX)/TSLOPE
32019       ENDIF
32020
32021 *   target hadron in Lab after scattering
32022       ELRH(2) = (TWO*AMT2-T)/(TWO*AAM(IT))
32023       PLRH(2) = SQRT( ABS(ELRH(2)-AAM(IT))*(ELRH(2)+AAM(IT)) )
32024       IF (PLRH(2).LE.TINY10) THEN
32025 C        WRITE(*,*)'ELHAIN: T,PLRH(2) ',T,PLRH(2)
32026          GOTO 1
32027       ENDIF
32028 *   projectile hadron in Lab after scattering
32029       ELRH(1) = ELAB+AAM(IT)-ELRH(2)
32030       PLRH(1) = SQRT( ABS(ELRH(1)-AAM(IP))*(ELRH(1)+AAM(IP)) )
32031 *   scattering angle of projectile in Lab
32032       CTLABP = (T-TWO*AMP2+TWO*ELAB*ELRH(1))/(TWO*PLAB*PLRH(1))
32033       STLABP = SQRT( (ONE-CTLABP)*(ONE+CTLABP) )
32034       CALL DT_DSFECF(SPLABP,CPLABP)
32035 *   direction cosines of projectile in Lab
32036       CALL DT_STTRAN(CX,CY,CZ,CTLABP,STLABP,SPLABP,CPLABP,
32037      &                          CXRH(1),CYRH(1),CZRH(1))
32038 *   scattering angle of target in Lab
32039       PLLABT = PLAB-CTLABP*PLRH(1)
32040       CTLABT = PLLABT/PLRH(2)
32041       STLABT = SQRT( (ONE-CTLABT)*(ONE+CTLABT) )
32042 *   direction cosines of target in Lab
32043       CALL DT_STTRAN(CX,CY,CZ,CTLABT,STLABT,-SPLABP,-CPLABP,
32044      &                            CXRH(2),CYRH(2),CZRH(2))
32045 *   fill /HNFSPA/
32046       IRH = 2
32047       ITRH(1) = IP
32048       ITRH(2) = IT
32049
32050       RETURN
32051       END
32052
32053 *$ CREATE DT_TSAMCS.FOR
32054 *COPY DT_TSAMCS
32055 *
32056 *===tsamcs=============================================================*
32057 *
32058       SUBROUTINE DT_TSAMCS(KPROJ,EKIN,CST)
32059
32060 ************************************************************************
32061 * Sampling of cos(theta) for nucleon-proton scattering according to    *
32062 * hetkfa2/bertini parametrization.                                     *
32063 * This is a revised version of the original (HJM 24/10/88)             *
32064 * This version dated 28.10.95 is written by S. Roesler                 *
32065 ************************************************************************
32066
32067       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32068       SAVE
32069
32070       PARAMETER ( LINP = 10 ,
32071      &            LOUT = 6 ,
32072      &            LDAT = 9 )
32073
32074       PARAMETER (TWO=2.0D0,ONE=1.0D0,OHALF=0.5D0,ZERO=0.0D0,
32075      &           TINY10=1.0D-10)
32076
32077       DIMENSION DCLIN(195),DCHN(143),DCHNA(36),DCHNB(60)
32078       DIMENSION PDCI(60),PDCH(55)
32079
32080       DATA (DCLIN(I),I=1,80) /
32081      &     5.000D-01,  1.000D+00,  0.000D+00,  1.000D+00,  0.000D+00,
32082      &     4.993D-01,  9.881D-01,  5.963D-02,  9.851D-01,  5.945D-02,
32083      &     4.936D-01,  8.955D-01,  5.224D-01,  8.727D-01,  5.091D-01,
32084      &     4.889D-01,  8.228D-01,  8.859D-01,  7.871D-01,  8.518D-01,
32085      &     4.874D-01,  7.580D-01,  1.210D+00,  7.207D-01,  1.117D+00,
32086      &     4.912D-01,  6.969D-01,  1.516D+00,  6.728D-01,  1.309D+00,
32087      &     5.075D-01,  6.471D-01,  1.765D+00,  6.667D-01,  1.333D+00,
32088      &     5.383D-01,  6.054D-01,  1.973D+00,  7.059D-01,  1.176D+00,
32089      &     5.397D-01,  5.990D-01,  2.005D+00,  7.023D-01,  1.191D+00,
32090      &     5.336D-01,  6.083D-01,  1.958D+00,  6.959D-01,  1.216D+00,
32091      &     5.317D-01,  6.075D-01,  1.962D+00,  6.897D-01,  1.241D+00,
32092      &     5.300D-01,  6.016D-01,  1.992D+00,  6.786D-01,  1.286D+00,
32093      &     5.281D-01,  6.063D-01,  1.969D+00,  6.786D-01,  1.286D+00,
32094      &     5.280D-01,  5.960D-01,  2.020D+00,  6.667D-01,  1.333D+00,
32095      &     5.273D-01,  5.920D-01,  2.040D+00,  6.604D-01,  1.358D+00,
32096      &     5.273D-01,  5.862D-01,  2.069D+00,  6.538D-01,  1.385D+00/
32097       DATA (DCLIN(I),I=81,160) /
32098      &     5.223D-01,  5.980D-01,  2.814D+00,  6.538D-01,  1.385D+00,
32099      &     5.202D-01,  5.969D-01,  2.822D+00,  6.471D-01,  1.412D+00,
32100      &     5.183D-01,  5.881D-01,  2.883D+00,  6.327D-01,  1.469D+00,
32101      &     5.159D-01,  5.866D-01,  2.894D+00,  6.250D-01,  1.500D+00,
32102      &     5.133D-01,  5.850D-01,  2.905D+00,  6.170D-01,  1.532D+00,
32103      &     5.106D-01,  5.833D-01,  2.917D+00,  6.087D-01,  1.565D+00,
32104      &     5.084D-01,  5.801D-01,  2.939D+00,  6.000D-01,  1.600D+00,
32105      &     5.063D-01,  5.763D-01,  2.966D+00,  5.909D-01,  1.636D+00,
32106      &     5.036D-01,  5.730D-01,  2.989D+00,  5.814D-01,  1.674D+00,
32107      &     5.014D-01,  5.683D-01,  3.022D+00,  5.714D-01,  1.714D+00,
32108      &     4.986D-01,  5.641D-01,  3.051D+00,  5.610D-01,  1.756D+00,
32109      &     4.964D-01,  5.580D-01,  3.094D+00,  5.500D-01,  1.800D+00,
32110      &     4.936D-01,  5.573D-01,  3.099D+00,  5.431D-01,  1.827D+00,
32111      &     4.909D-01,  5.509D-01,  3.144D+00,  5.313D-01,  1.875D+00,
32112      &     4.885D-01,  5.512D-01,  3.142D+00,  5.263D-01,  1.895D+00,
32113      &     4.857D-01,  5.437D-01,  3.194D+00,  5.135D-01,  1.946D+00/
32114       DATA (DCLIN(I),I=161,195) /
32115      &     4.830D-01,  5.353D-01,  3.253D+00,  5.000D-01,  2.000D+00,
32116      &     4.801D-01,  5.323D-01,  3.274D+00,  4.915D-01,  2.034D+00,
32117      &     4.770D-01,  5.228D-01,  3.341D+00,  4.767D-01,  2.093D+00,
32118      &     4.738D-01,  5.156D-01,  3.391D+00,  4.643D-01,  2.143D+00,
32119      &     4.701D-01,  5.010D-01,  3.493D+00,  4.444D-01,  2.222D+00,
32120      &     4.672D-01,  4.990D-01,  3.507D+00,  4.375D-01,  2.250D+00,
32121      &     4.634D-01,  4.856D-01,  3.601D+00,  4.194D-01,  2.323D+00/
32122
32123       DATA PDCI /
32124      &     4.400D+02,  1.896D-01,  1.931D-01,  1.982D-01,  1.015D-01,
32125      &     1.029D-01,  4.180D-02,  4.228D-02,  4.282D-02,  4.350D-02,
32126      &     2.204D-02,  2.236D-02,  5.900D+02,  1.433D-01,  1.555D-01,
32127      &     1.774D-01,  1.000D-01,  1.128D-01,  5.132D-02,  5.600D-02,
32128      &     6.158D-02,  6.796D-02,  3.660D-02,  3.820D-02,  6.500D+02,
32129      &     1.192D-01,  1.334D-01,  1.620D-01,  9.527D-02,  1.141D-01,
32130      &     5.283D-02,  5.952D-02,  6.765D-02,  7.878D-02,  4.796D-02,
32131      &     6.957D-02,  8.000D+02,  4.872D-02,  6.694D-02,  1.152D-01,
32132      &     9.348D-02,  1.368D-01,  6.912D-02,  7.953D-02,  9.577D-02,
32133      &     1.222D-01,  7.755D-02,  9.525D-02,  1.000D+03,  3.997D-02,
32134      &     5.456D-02,  9.804D-02,  8.084D-02,  1.208D-01,  6.520D-02,
32135      &     8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,  1.093D-01/
32136
32137       DATA PDCH /
32138      &     1.000D+03,  9.453D-02,  9.804D-02,  8.084D-02,  1.208D-01,
32139      &     6.520D-02,  8.233D-02,  1.084D-01,  1.474D-01,  9.328D-02,
32140      &     1.093D-01,  1.400D+03,  1.072D-01,  7.450D-02,  6.645D-02,
32141      &     1.136D-01,  6.750D-02,  8.580D-02,  1.110D-01,  1.530D-01,
32142      &     1.010D-01,  1.350D-01,  2.170D+03,  4.004D-02,  3.013D-02,
32143      &     2.664D-02,  5.511D-02,  4.240D-02,  7.660D-02,  1.364D-01,
32144      &     2.300D-01,  1.670D-01,  2.010D-01,  2.900D+03,  1.870D-02,
32145      &     1.804D-02,  1.320D-02,  2.970D-02,  2.860D-02,  5.160D-02,
32146      &     1.020D-01,  2.400D-01,  2.250D-01,  3.370D-01,  4.400D+03,
32147      &     1.196D-03,  8.784D-03,  1.517D-02,  2.874D-02,  2.488D-02,
32148      &     4.464D-02,  8.330D-02,  2.008D-01,  2.360D-01,  3.567D-01/
32149
32150       DATA (DCHN(I),I=1,90) /
32151      &     4.770D-01,  4.750D-01,  4.715D-01,  4.685D-01,  4.650D-01,
32152      &     4.610D-01,  4.570D-01,  4.550D-01,  4.500D-01,  4.450D-01,
32153      &     4.405D-01,  4.350D-01,  4.300D-01,  4.250D-01,  4.200D-01,
32154      &     4.130D-01,  4.060D-01,  4.000D-01,  3.915D-01,  3.840D-01,
32155      &     3.760D-01,  3.675D-01,  3.580D-01,  3.500D-01,  3.400D-01,
32156      &     3.300D-01,  3.200D-01,  3.100D-01,  3.000D-01,  2.900D-01,
32157      &     2.800D-01,  2.700D-01,  2.600D-01,  2.500D-01,  2.400D-01,
32158      &     2.315D-01,  2.240D-01,  2.150D-01,  2.060D-01,  2.000D-01,
32159      &     1.915D-01,  1.850D-01,  1.780D-01,  1.720D-01,  1.660D-01,
32160      &     1.600D-01,  1.550D-01,  1.500D-01,  1.450D-01,  1.400D-01,
32161      &     1.360D-01,  1.320D-01,  1.280D-01,  1.250D-01,  1.210D-01,
32162      &     1.180D-01,  1.150D-01,  1.120D-01,  1.100D-01,  1.070D-01,
32163      &     1.050D-01,  1.030D-01,  1.010D-01,  9.900D-02,  9.700D-02,
32164      &     9.550D-02,  9.480D-02,  9.400D-02,  9.200D-02,  9.150D-02,
32165      &     9.100D-02,  9.000D-02,  8.990D-02,  8.900D-02,  8.850D-02,
32166      &     8.750D-02,  8.700D-02,  8.650D-02,  8.550D-02,  8.500D-02,
32167      &     8.499D-02,  8.450D-02,  8.350D-02,  8.300D-02,  8.250D-02,
32168      &     8.150D-02,  8.100D-02,  8.030D-02,  8.000D-02,  7.990D-02/
32169       DATA (DCHN(I),I=91,143) /
32170      &     7.980D-02,  7.950D-02,  7.900D-02,  7.860D-02,  7.800D-02,
32171      &     7.750D-02,  7.650D-02,  7.620D-02,  7.600D-02,  7.550D-02,
32172      &     7.530D-02,  7.500D-02,  7.499D-02,  7.498D-02,  7.480D-02,
32173      &     7.450D-02,  7.400D-02,  7.350D-02,  7.300D-02,  7.250D-02,
32174      &     7.230D-02,  7.200D-02,  7.100D-02,  7.050D-02,  7.020D-02,
32175      &     7.000D-02,  6.999D-02,  6.995D-02,  6.993D-02,  6.991D-02,
32176      &     6.990D-02,  6.870D-02,  6.850D-02,  6.800D-02,  6.780D-02,
32177      &     6.750D-02,  6.700D-02,  6.650D-02,  6.630D-02,  6.600D-02,
32178      &     6.550D-02,  6.525D-02,  6.510D-02,  6.500D-02,  6.499D-02,
32179      &     6.498D-02,  6.496D-02,  6.494D-02,  6.493D-02,  6.490D-02,
32180      &     6.488D-02,  6.485D-02,  6.480D-02/
32181
32182       DATA DCHNA /
32183      &     6.300D+02,  7.810D-02,  1.421D-01,  1.979D-01,  2.479D-01,
32184      &     3.360D-01,  5.400D-01,  7.236D-01,  1.000D+00,  1.540D+03,
32185      &     2.225D-01,  3.950D-01,  5.279D-01,  6.298D-01,  7.718D-01,
32186      &     9.405D-01,  9.835D-01,  1.000D+00,  2.560D+03,  2.625D-01,
32187      &     4.550D-01,  5.963D-01,  7.020D-01,  8.380D-01,  9.603D-01,
32188      &     9.903D-01,  1.000D+00,  3.520D+03,  4.250D-01,  6.875D-01,
32189      &     8.363D-01,  9.163D-01,  9.828D-01,  1.000D+00,  1.000D+00,
32190      &     1.000D+00/
32191
32192       DATA DCHNB /
32193      &     6.300D+02,  3.800D-02,  7.164D-02,  1.275D-01,  2.171D-01,
32194      &     3.227D-01,  4.091D-01,  5.051D-01,  6.061D-01,  7.074D-01,
32195      &     8.434D-01,  1.000D+00,  2.040D+03,  1.200D-01,  2.115D-01,
32196      &     3.395D-01,  5.295D-01,  7.251D-01,  8.511D-01,  9.487D-01,
32197      &     9.987D-01,  1.000D+00,  1.000D+00,  1.000D+00,  2.200D+03,
32198      &     1.344D-01,  2.324D-01,  3.754D-01,  5.674D-01,  7.624D-01,
32199      &     8.896D-01,  9.808D-01,  1.000D+00,  1.000D+00,  1.000D+00,
32200      &     1.000D+00,  2.850D+03,  2.330D-01,  4.130D-01,  6.610D-01,
32201      &     9.010D-01,  9.970D-01,  1.000D+00,  1.000D+00,  1.000D+00,
32202      &     1.000D+00,  1.000D+00,  1.000D+00,  3.500D+03,  3.300D-01,
32203      &     5.450D-01,  7.950D-01,  1.000D+00,  1.000D+00,  1.000D+00,
32204      &     1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00,  1.000D+00/
32205
32206       CST = ONE
32207       IF (EKIN.GT.3.5D0) RETURN
32208 C
32209       IF(KPROJ.EQ.8) GOTO 101
32210       IF(KPROJ.EQ.1) GOTO 102
32211 C*                                             INVALID REACTION
32212       WRITE(LOUT,'(A,I5/A)')
32213      &        ' INVALID PARTICLE TYPE IN DNUPRE - KPROJ=',KPROJ,
32214      &        ' COS(THETA) = 1D0 RETURNED'
32215       RETURN
32216 C-------------------------------- NP ELASTIC SCATTERING----------
32217 101   CONTINUE
32218       IF (EKIN.GT.0.740D0)GOTO 1000
32219       IF (EKIN.LT.0.300D0)THEN
32220 C                                 EKIN .LT. 300 MEV
32221          IDAT=1
32222       ELSE
32223 C                                 300 MEV < EKIN < 740 MEV
32224          IDAT=6
32225       END IF
32226 C
32227       ENER=EKIN
32228       IE=INT(ABS(ENER/0.020D0))
32229       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32230 C                                            FORWARD/BACKWARD DECISION
32231       K=IDAT+5*IE
32232       BWFW=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32233       IF (DT_RNDM(CST).LT.BWFW)THEN
32234          VALUE2=-1D0
32235          K=K+1
32236       ELSE
32237          VALUE2=1D0
32238          K=K+3
32239       END IF
32240 C
32241       COEF=(DCLIN(K+5)-DCLIN(K))*UNIV + DCLIN(K)
32242       RND=DT_RNDM(COEF)
32243 C
32244       IF(RND.LT.COEF)THEN
32245          CST=DT_RNDM(RND)
32246          CST=CST*VALUE2
32247       ELSE
32248          R1=DT_RNDM(CST)
32249          R2=DT_RNDM(R1)
32250          R3=DT_RNDM(R2)
32251          R4=DT_RNDM(R3)
32252 C
32253          IF(VALUE2.GT.0.0)THEN
32254             CST=MAX(R1,R2,R3,R4)
32255             GOTO 1500
32256          ELSE
32257             R5=DT_RNDM(R4)
32258 C
32259             IF (IDAT.EQ.1)THEN
32260                CST=-MAX(R1,R2,R3,R4,R5)
32261             ELSE
32262                R6=DT_RNDM(R5)
32263                R7=DT_RNDM(R6)
32264                CST=-MAX(R1,R2,R3,R4,R5,R6,R7)
32265             END IF
32266 C
32267          END IF
32268 C
32269       END IF
32270 C
32271       GOTO 1500
32272 C
32273 C********                                EKIN  .GT.  0.74 GEV
32274 C
32275 1000  ENER=EKIN - 0.66D0
32276 C     IE=ABS(ENER/0.02)
32277       IE=INT(ENER/0.02D0)
32278       EMEV=EKIN*1D3
32279 C
32280       UNIV=(ENER-DBLE(IE)*0.020D0)/0.020D0
32281       K=IE
32282       BWFW=(DCHN(K+1)-DCHN(K))*UNIV + DCHN(K)
32283       RND=DT_RNDM(BWFW)
32284 C                                        FORWARD NEUTRON
32285       IF (RND.GE.BWFW)THEN
32286          DO 1200 K=10,36,9
32287            IF (DCHNA(K).GT.EMEV) THEN
32288               UNIVE=(EMEV-DCHNA(K-9))/(DCHNA(K)-DCHNA(K-9))
32289               UNIV=DT_RNDM(UNIVE)
32290               DO 1100 I=1,8
32291                  II=K+I
32292                  P=(DCHNA(II)-DCHNA(II-9))*UNIVE + DCHNA(II-9)
32293 C
32294                  IF (P.GT.UNIV)THEN
32295                     UNIV=DT_RNDM(UNIVE)
32296                     FLTI=DBLE(I)-UNIV
32297                     GOTO(290,290,290,290,330,340,350,360) I
32298                  END IF
32299  1100         CONTINUE
32300            END IF
32301  1200    CONTINUE
32302 C
32303       ELSE
32304 C                                        BACKWARD NEUTRON
32305          DO 1400 K=13,60,12
32306             IF (DCHNB(K).GT.EMEV) THEN
32307                UNIVE=(EMEV-DCHNB(K-12))/(DCHNB(K)-DCHNB(K-12))
32308                UNIV=DT_RNDM(UNIVE)
32309                DO 1300 I=1,11
32310                  II=K+I
32311                  P=(DCHNB(II)-DCHNB(II-12))*UNIVE + DCHNB(II-12)
32312 C
32313                  IF (P.GT.UNIV)THEN
32314                    UNIV=DT_RNDM(P)
32315                    FLTI=DBLE(I)-UNIV
32316                    GOTO(120,120,140,150,160,160,180,190,200,210,220) I
32317                  END IF
32318  1300          CONTINUE
32319             END IF
32320  1400    CONTINUE
32321       END IF
32322 C
32323 120   CST=1.0D-2*FLTI-1.0D0
32324       GOTO 1500
32325 140   CST=2.0D-2*UNIV-0.98D0
32326       GOTO 1500
32327 150   CST=4.0D-2*UNIV-0.96D0
32328       GOTO 1500
32329 160   CST=6.0D-2*FLTI-1.16D0
32330       GOTO 1500
32331 180   CST=8.0D-2*UNIV-0.80D0
32332       GOTO 1500
32333 190   CST=1.0D-1*UNIV-0.72D0
32334       GOTO 1500
32335 200   CST=1.2D-1*UNIV-0.62D0
32336       GOTO 1500
32337 210   CST=2.0D-1*UNIV-0.50D0
32338       GOTO 1500
32339 220   CST=3.0D-1*(UNIV-1.0D0)
32340       GOTO 1500
32341 C
32342 290   CST=1.0D0-2.5d-2*FLTI
32343       GOTO 1500
32344 330   CST=0.85D0+0.5D-1*UNIV
32345       GOTO 1500
32346 340   CST=0.70D0+1.5D-1*UNIV
32347       GOTO 1500
32348 350   CST=0.50D0+2.0D-1*UNIV
32349       GOTO 1500
32350 360   CST=0.50D0*UNIV
32351 C
32352 1500  RETURN
32353 C
32354 C-----------------------------------  PP ELASTIC SCATTERING -------
32355 C
32356  102  CONTINUE
32357       EMEV=EKIN*1D3
32358 C
32359       IF (EKIN.LE.0.500D0) THEN
32360          RND=DT_RNDM(EMEV)
32361          CST=2.0D0*RND-1.0D0
32362          RETURN
32363 C
32364       ELSEIF (EKIN.LT.1.0D0) THEN
32365          DO 2200 K=13,60,12
32366             IF (PDCI(K).GT.EMEV) THEN
32367                UNIVE=(EMEV-PDCI(K-12))/(PDCI(K)-PDCI(K-12))
32368                UNIV=DT_RNDM(UNIVE)
32369                SUM=0
32370                DO 2100 I=1,11
32371                  II=K+I
32372                  SUM=SUM + (PDCI(II)-PDCI(II-12))*UNIVE + PDCI(II-12)
32373 C
32374                  IF (UNIV.LT.SUM)THEN
32375                    UNIV=DT_RNDM(SUM)
32376                    FLTI=DBLE(I)-UNIV
32377                    GOTO(55,55,55,60,60,65,65,65,65,70,70) I
32378                  END IF
32379  2100          CONTINUE
32380             END IF
32381  2200    CONTINUE
32382       ELSE
32383          DO 2400 K=12,55,11
32384             IF (PDCH(K).GT.EMEV) THEN
32385               UNIVE=(EMEV-PDCH(K-11))/(PDCH(K)-PDCH(K-11))
32386               UNIV=DT_RNDM(UNIVE)
32387               SUM=0.0D0
32388               DO 2300 I=1,10
32389                 II=K+I
32390                 SUM=SUM + (PDCH(II)-PDCH(II-11))*UNIVE + PDCH(II-11)
32391 C
32392                 IF (UNIV.LT.SUM)THEN
32393                   UNIV=DT_RNDM(SUM)
32394                   FLTI=UNIV+DBLE(I)
32395                   GOTO(50,55,60,60,65,65,65,65,70,70) I
32396                 END IF
32397  2300         CONTINUE
32398             END IF
32399  2400    CONTINUE
32400       END IF
32401 C
32402 50    CST=0.4D0*UNIV
32403       GOTO 2500
32404 55    CST=0.2D0*FLTI
32405       GOTO 2500
32406 60    CST=0.3D0+0.1D0*FLTI
32407       GOTO 2500
32408 65    CST=0.6D0+0.04D0*FLTI
32409       GOTO 2500
32410 70    CST=0.78D0+0.02D0*FLTI
32411 C
32412 2500  CONTINUE
32413       IF (DT_RNDM(CST).GT.0.5D0) CST=-CST
32414 C
32415       RETURN
32416       END
32417
32418 *$ CREATE DT_DHADRI.FOR
32419 *COPY DT_DHADRI
32420 *
32421 *===dhadri=============================================================*
32422 *
32423       SUBROUTINE DT_DHADRI(N,PLAB,ELAB,CX,CY,CZ,ITTA)
32424
32425       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32426       SAVE
32427
32428       PARAMETER ( LINP = 10 ,
32429      &            LOUT = 6 ,
32430      &            LDAT = 9 )
32431
32432 C
32433 C-----------------------------
32434 C*** INPUT VARIABLES LIST:
32435 C*** SAMPLING OF HADRON NUCLEON INTERACTION FOR (ABOUT) 0.1 LE PLAB LE 6
32436 C*** GEV/C LABORATORY MOMENTUM REGION
32437 C*** N    - PROJECTILE HADRON INDEX
32438 C*** PLAB - LABORATORY MOMENTUM OF N (GEV/C)
32439 C*** ELAB - LABORATORY ENERGY OF N (GEV)
32440 C*** CX,CY,CZ - DIRECTION COSINES OF N IN THE LABORATORY SYSTEM
32441 C*** ITTA - TARGET NUCLEON INDEX
32442 C*** OUTPUT VARIABLES LIST OF PARTICLE CHARACTERISTICS IN /FINLSP/
32443 C  IR COUNTS THE NUMBER OF PRODUCED PARTICLES
32444 C*** ITR - PARTICLE INDEX, CXR,CYR,CZR - DIRECTION COSINES (LAB. SYST.)
32445 C*** ELR,PLR LAB. ENERGY AND LAB. MOMENTUM OF THE SAMPLED PARTICLE
32446 C*** RESPECT., UNITS (GEV/C AND GEV)
32447 C----------------------------
32448
32449       COMMON /HNGAMR/ REDU,AMO,AMM(15)
32450
32451       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32452
32453       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32454      &                NRK(2,268),NURE(30,2)
32455
32456 * particle properties (BAMJET index convention),
32457 * (dublicate of DTPART for HADRIN)
32458       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32459      &                K1H(110),K2H(110)
32460
32461       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32462
32463       COMMON /HNMETL/ CXS(149),CYS(149),CZS(149),ELS(149),PLS(149),
32464      &                ITS(149),IS
32465
32466       COMMON /HNDRUN/ RUNTES,EFTES
32467
32468 * particle properties (BAMJET index convention)
32469       CHARACTER*8  ANAME
32470       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
32471      &                IICH(210),IIBAR(210),K1(210),K2(210)
32472
32473 * final state from HADRIN interaction
32474       PARAMETER (MAXFIN=10)
32475       COMMON /HNFSPA/ ITRH(MAXFIN),CXRH(MAXFIN),CYRH(MAXFIN),
32476      &                CZRH(MAXFIN),ELRH(MAXFIN),PLRH(MAXFIN),IRH
32477
32478       DIMENSION ITPRF(110)
32479       DATA NNN/0/
32480       DATA UMODA/0./
32481       DATA ITPRF/-1,-1,5*1,-1,-1,1,1,1,-1,-1,-1,-1,6*1,-1,-1,-1,85*1/
32482       LOWP=0
32483       IF (N.LE.0.OR.N.GE.111)N=1
32484       IF (ITPRF( N ).GT.0 .OR. ITTA.GT.8) THEN
32485         GOTO 280
32486 *       WRITE (6,1000)
32487 *    +  ' FALSE USE OF THE PARTICLE TYPE INDEX: N, ITTA', N, ITTA
32488 *       STOP
32489 *1000   FORMAT (3(5H ****/),A,2I4,3(5H ****/))
32490 *    +  45H FALSE USE OF THE PARTICLE TYPE INDEX, N,LUE ,I4,3(5H ****/))
32491       ENDIF
32492       IATMPT=0
32493       IF (ABS(PLAB-5.0D0).LT.4.99999D0)                        GO TO 20
32494 C     IF(IPRI.GE.1) WRITE (6,1010) PLAB
32495 C     STOP
32496  1010 FORMAT ( '  PROJECTILE HADRON MOMENTUM OUTSIDE OF THE
32497      + ALLOWED REGION, PLAB=',1E15.5)
32498
32499    20 CONTINUE
32500       UMODAT=N*1.11111D0+ITTA*2.19291D0
32501       IF(UMODAT.NE.UMODA) CALL DT_DCALUM(N,ITTA)
32502       UMODA=UMODAT
32503    30 IATMPT=0
32504       LOWP=LOWP+1
32505    40 CONTINUE
32506       IMACH=0
32507       REDU=2.0D0
32508       IF (LOWP.GT.20) THEN
32509 C        WRITE(LOUT,*) ' jump 1'
32510          GO TO 280
32511       ENDIF
32512       NNN=N
32513       IF (NNN.EQ.N)                                             GO TO 50
32514       RUNTES=0.0D0
32515       EFTES=0.0D0
32516    50 CONTINUE
32517       IS=1
32518       IRH=0
32519       IST=1
32520       NSTAB=23
32521       IRE=NURE(N,1)
32522       IF(ITTA.GT.1) IRE=NURE(N,2)
32523 C
32524 C-----------------------------
32525 C*** IE,AMT,ECM,SI DETERMINATION
32526 C----------------------------
32527       CALL DT_DSIGIN(IRE,PLAB,N,IE,AMT ,AMN,ECM,SI,ITTA)
32528       IANTH=-1
32529 **sr
32530 C     IF (AMH(1).NE.0.93828D0) IANTH=1
32531       IF (AMH(1).NE.0.9383D0) IANTH=1
32532 **
32533       IF (IANTH.GE.0) SI=1.0D0
32534       ECMMH=ECM
32535 C
32536 C-----------------------------
32537 C    ENERGY INDEX
32538 C  IRE CHARACTERIZES THE REACTION
32539 C  IE IS THE ENERGY INDEX
32540 C----------------------------
32541       IF (SI.LT.1.D-6) THEN
32542 C        WRITE(LOUT,*) ' jump 2'
32543          GO TO 280
32544       ENDIF
32545       IF (N.LE.NSTAB)                                           GO TO 60
32546       RUNTES=RUNTES+1.0D0
32547       IF (RUNTES.LT.20.D0) WRITE(LOUT,1020)N
32548  1020 FORMAT(3H N=,I10,30H THE PROEKTILE IS A RESONANCE )
32549       IF(IBARH(N).EQ.1) N=8
32550       IF(IBARH(N).EQ.-1)  N=9
32551    60 CONTINUE
32552       IMACH=IMACH+1
32553 **sr 19.2.97: loop for direct channel suppression
32554 C     IF (IMACH.GT.10) THEN
32555       IF (IMACH.GT.1000) THEN
32556 **
32557 C        WRITE(LOUT,*) ' jump 3'
32558          GO TO 280
32559       ENDIF
32560       ECM =ECMMH
32561       AMN2=AMN**2
32562       AMT2=AMT**2
32563       ECMN=(ECM**2+AMN2-AMT2)/(2.0D0*ECM    )
32564       IF(ECMN.LE.AMN) ECMN=AMN
32565       PCMN=SQRT(ECMN**2-AMN2)
32566       GAM=(ELAB+AMT)/ECM
32567       BGAM=PLAB/ECM
32568       IF (IANTH.GE.0) ECM=2.1D0
32569 C
32570 C-----------------------------
32571 C*** RANDOM CHOICE OF REACTION CHANNEL
32572 C----------------------------
32573       IST=0
32574       VV=DT_RNDM(AMN2)
32575       VV=VV-1.D-17
32576 C
32577 C-----------------------------
32578 C***  PLACE REDUCED VERSION
32579 C----------------------------
32580       IIEI=IEII(IRE)
32581       IDWK=IEII(IRE+1)-IIEI
32582       IIWK=IRII(IRE)
32583       IIKI=IKII(IRE)
32584 C
32585 C-----------------------------
32586 C***  SHRINKAGE TO THE CONSIDERED ENERGY REGION FOR THE USE OF WEIGHTS
32587 C----------------------------
32588       HECM=ECM
32589       HUMO=2.0D0*UMO(IIEI+IDWK)-UMO(IIEI+IDWK-1)
32590       IF (HUMO.LT.ECM) ECM=HUMO
32591 C
32592 C-----------------------------
32593 C*** INTERPOLATION PREPARATION
32594 C----------------------------
32595       ECMO=UMO(IE)
32596       ECM1=UMO(IE-1)
32597       DECM=ECMO-ECM1
32598       DEC=ECMO-ECM
32599 C
32600 C-----------------------------
32601 C*** RANDOM LOOP
32602 C----------------------------
32603       IK=0
32604       WKK=0.0D0
32605       WICOR=0.0D0
32606    70 IK=IK+1
32607       IWK=IIWK+(IK-1)*IDWK+IE-IIEI
32608       WOK=WK(IWK)
32609       WDK=WOK-WK(IWK-1)
32610 C
32611 C-----------------------------
32612 C*** TESTVARIABLE WICO/WICOR: IF CHANNEL IK HAS THE SAME WEIGHTS LIKE IK
32613 C    GO TO NEXT CHANNEL, BECAUSE WKK((IK))-WKK((IK-1))=0, IK CAN NOT
32614 C    CONTRIBUTE
32615 C----------------------------
32616       IF (PLAB.LT.PLABF(IIEI+2)) WDK=0.0D0
32617       WICO=WOK*1.23459876D0+WDK*1.735218469D0
32618       IF (WICO.EQ.WICOR)                                        GO TO 70
32619       IF (UMO(IIEI+IDWK).LT.HECM) WDK=0.0D0
32620       WICOR=WICO
32621 C
32622 C-----------------------------
32623 C*** INTERPOLATION IN CHANNEL WEIGHTS
32624 C----------------------------
32625       EKLIM=-THRESH(IIKI+IK)
32626       IELIM=IDT_IEFUND(EKLIM,IRE)
32627       DELIM=UMO(IELIM)+EKLIM
32628      *+1.D-16
32629       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
32630       IF (DELIM*DELIM-DETE*DETE) 90,90,80
32631    80 DECC=DELIM
32632                                                                GO TO 100
32633    90 DECC=DECM
32634   100 CONTINUE
32635       WKK=WOK-WDK*DEC/(DECC+1.D-9)
32636 C
32637 C-----------------------------
32638 C*** RANDOM CHOICE
32639 C----------------------------
32640 C
32641       IF (VV.GT.WKK)                                            GO TO 70
32642 C
32643 C***IK IS THE REACTION CHANNEL
32644 C----------------------------
32645       INRK=IKII(IRE)+IK
32646       ECM=HECM
32647       I1001 =0
32648 C
32649   110 CONTINUE
32650       IT1=NRK(1,INRK)
32651       AM1=DT_DAMG(IT1)
32652       IT2=NRK(2,INRK)
32653       AM2=DT_DAMG(IT2)
32654       AMS=AM1+AM2
32655       I1001=I1001+1
32656       IF (I1001.GT.50)                                          GO TO 60
32657 C
32658       IF (IT2*AMS.GT.IT2*ECM)                                  GO TO 110
32659       IT11=IT1
32660       IT22=IT2
32661       IF (IANTH.GE.0) ECM=ELAB+AMT+0.00001D0
32662       AM11=AM1
32663       AM22=AM2
32664       IF (IT2.GT.0)                                            GO TO 120
32665 **sr 19.2.97: supress direct channel for pp-collisions
32666       IF ((N.EQ.1).AND.(ITTA.EQ.1).AND.(IT2.LE.0)) THEN
32667          RR = DT_RNDM(AM11)
32668          IF (RR.LE.0.75D0) GOTO 60
32669       ENDIF
32670 **
32671 C
32672 C-----------------------------
32673 C  INCLUSION OF DIRECT RESONANCES
32674 C  RANDOM CHOICE OF DECAY CHANNELS OF THE DIRECT RESONANCE  IT1
32675 C------------------------
32676       KZ1=K1H(IT1)
32677       IST=IST+1
32678       IECO=0
32679       ECO=ECM
32680       GAM=(ELAB+AMT)/ECO
32681       BGAM=PLAB/ECO
32682       CXS(1)=CX
32683       CYS(1)=CY
32684       CZS(1)=CZ
32685                                                                GO TO 170
32686   120 CONTINUE
32687       WW=DT_RNDM(ECO)
32688       IF(WW.LT. 0.5D0)                                         GO TO 130
32689       IT1=IT22
32690       IT2=IT11
32691       AM1=AM22
32692       AM2=AM11
32693   130 CONTINUE
32694 C
32695 C-----------------------------
32696 C   THE FIRST PARTICLE IS DEFINED TO BE THE FORWARD GOING ONE AT SMALL T
32697       IBN=IBARH(N)
32698       IB1=IBARH(IT1)
32699       IT11=IT1
32700       IT22=IT2
32701       AM11=AM1
32702       AM22=AM2
32703       IF(IB1.EQ.IBN)                                           GO TO 140
32704       IT1=IT22
32705       IT2=IT11
32706       AM1=AM22
32707       AM2=AM11
32708   140 CONTINUE
32709 C-----------------------------
32710 C***IT1,IT2 ARE THE CREATED PARTICLES
32711 C***MOMENTA AND DIRECTION COSINA IN THE CM - SYSTEM
32712 C------------------------
32713       CALL DT_DTWOPA(ECM1,ECM2,PCM1,PCM2,COD1,COD2,COF1,COF2,SIF1,SIF2,
32714      *IT1,IT2,ECM,ECMN,PCMN,N,AM1,AM2)
32715       IST=IST+1
32716       ITS(IST)=IT1
32717       AMM(IST)=AM1
32718 C
32719 C-----------------------------
32720 C***TRANSFORMATION INTO LAB SYSTEM AND ROTATION
32721 C----------------------------
32722       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD1,COF1,SIF1,
32723      &PCM1,ECM1,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32724       IST=IST+1
32725       ITS(IST)=IT2
32726       AMM(IST)=AM2
32727       CALL DT_DTRAFO(GAM,BGAM,CX,CY,CZ,COD2,COF2,SIF2,
32728      *PCM2,ECM2,PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32729   150 CONTINUE
32730 C
32731 C-----------------------------
32732 C***TEST   STABLE OR UNSTABLE
32733 C----------------------------
32734       IF(ITS(IST).GT.NSTAB)                                    GO TO 160
32735       IRH=IRH+1
32736 C
32737 C-----------------------------
32738 C***IRH IS THE NUMBER OF THE FINAL STABLE PARTICLE
32739 C----------------------------
32740 C*    IF (REDU.LT.0.D0) GO TO 1009
32741       ITRH(IRH)=ITS(IST)
32742       PLRH(IRH)=PLS(IST)
32743       CXRH(IRH)=CXS(IST)
32744       CYRH(IRH)=CYS(IST)
32745       CZRH(IRH)=CZS(IST)
32746       ELRH(IRH)=ELS(IST)
32747       IST=IST-1
32748       IF(IST.GE.1)                                             GO TO 150
32749                                                                GO TO 260
32750   160 CONTINUE
32751 C
32752 C  RANDOM CHOICE OF DECAY CHANNELS
32753 C----------------------------
32754 C
32755       IT=ITS(IST)
32756       ECO=AMM(IST)
32757       GAM=ELS(IST)/ECO
32758       BGAM=PLS(IST)/ECO
32759       IECO=0
32760       KZ1=K1H(IT)
32761   170 CONTINUE
32762       IECO=IECO+1
32763       VV=DT_RNDM(GAM)
32764       VV=VV-1.D-17
32765       IIK=KZ1-1
32766   180 IIK=IIK+1
32767       IF (VV.GT.WTI(IIK))                                      GO TO 180
32768 C
32769 C  IIK IS THE DECAY CHANNEL
32770 C----------------------------
32771       IT1=NZKI(IIK,1)
32772       I310=0
32773   190 CONTINUE
32774       I310=I310+1
32775       AM1=DT_DAMG(IT1)
32776       IT2=NZKI(IIK,2)
32777       AM2=DT_DAMG(IT2)
32778       IF (IT2-1.LT.0)                                          GO TO 240
32779       IT3=NZKI(IIK,3)
32780       AM3=DT_DAMG(IT3)
32781       AMS=AM1+AM2+AM3
32782 C
32783 C  IF  IIK-KIN.LIM.GT.ACTUAL TOTAL CM-ENERGY, DO AGAIN RANDOM IIK-CHOICE
32784 C----------------------------
32785       IF (IECO.LE.10)                                          GO TO 200
32786       IATMPT=IATMPT+1
32787       IF(IATMPT.GT.3) THEN
32788 C        WRITE(LOUT,*) ' jump 4'
32789          GO TO 280
32790       ENDIF
32791                                                                 GO TO 40
32792   200 CONTINUE
32793       IF (I310.GT.50)                                          GO TO 170
32794       IF (AMS.GT.ECO)                                          GO TO 190
32795 C
32796 C  FOR THE DECAY CHANNEL
32797 C  IT1,IT2, IT3 ARE THE PRODUCED PARTICLES FROM  IT
32798 C----------------------------
32799       IF (REDU.LT.0.D0)                                        GO TO 30
32800       ITWTHC=0
32801       REDU=2.0D0
32802       IF(IT3.EQ.0)                                             GO TO 220
32803   210 CONTINUE
32804       ITWTH=1
32805       CALL DT_DTHREP(ECO,ECM1,ECM2,ECM3,PCM1,PCM2,PCM3,COD1,COF1,SIF1,
32806      *COD2,COF2,SIF2,COD3,COF3,SIF3,AM1,AM2,AM3)
32807                                                                GO TO 230
32808   220 CALL DT_DTWOPD(ECO,ECM1,ECM2,PCM1,PCM2,COD1,COF1,SIF1,
32809      &COD2,COF2,SIF2,AM1,AM2)
32810       ITWTH=-1
32811       IT3=0
32812   230 CONTINUE
32813       ITWTHC=ITWTHC+1
32814       IF (REDU.GT.0.D0)                                        GO TO 240
32815       REDU=2.0D0
32816       IF (ITWTHC.GT.100)                                        GO TO 30
32817       IF (ITWTH) 220,220,210
32818   240 CONTINUE
32819       ITS(IST  )=IT1
32820       IF (IT2-1.LT.0)                                          GO TO 250
32821       ITS(IST+1)  =IT2
32822       ITS(IST+2)=IT3
32823       RX=CXS(IST)
32824       RY=CYS(IST)
32825       RZ=CZS(IST)
32826       AMM(IST)=AM1
32827       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD1,COF1,SIF1,PCM1,ECM1,
32828      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32829       IST=IST+1
32830       AMM(IST)=AM2
32831       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD2,COF2,SIF2,PCM2,ECM2,
32832      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32833       IF (IT3.LE.0)                                            GO TO 250
32834       IST=IST+1
32835       AMM(IST)=AM3
32836       CALL DT_DTRAFO(GAM,BGAM,RX,RY,RZ,COD3,COF3,SIF3,PCM3,ECM3,
32837      *PLS(IST),CXS(IST),CYS(IST),CZS(IST),ELS(IST))
32838   250 CONTINUE
32839                                                                GO TO 150
32840   260 CONTINUE
32841   270 CONTINUE
32842       RETURN
32843   280 CONTINUE
32844 C
32845 C----------------------------
32846 C
32847 C   ZERO CROSS SECTION CASE
32848 C----------------------------
32849 C
32850       IRH=1
32851       ITRH(1)=N
32852       CXRH(1)=CX
32853       CYRH(1)=CY
32854       CZRH(1)=CZ
32855       ELRH(1)=ELAB
32856       PLRH(1)=PLAB
32857       RETURN
32858       END
32859
32860 *$ CREATE DT_RUNTT.FOR
32861 *COPY DT_RUNTT
32862 *
32863 *===runtt==============================================================*
32864 *
32865       BLOCK DATA DT_RUNTT
32866
32867       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32868       SAVE
32869
32870       COMMON /HNDRUN/ RUNTES,EFTES
32871
32872       DATA RUNTES,EFTES /100.D0,100.D0/
32873
32874       END
32875
32876 *$ CREATE DT_NONAME.FOR
32877 *COPY DT_NONAME
32878 *
32879 *===noname=============================================================*
32880 *
32881       BLOCK DATA DT_NONAME
32882
32883       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32884       SAVE
32885
32886 * slope parameters for HADRIN interactions
32887       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
32888
32889       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32890
32891 C     DATAS     DATAS    DATAS      DATAS     DATAS
32892 C******          *********
32893       DATA IKII/ 0, 15, 41, 67, 82, 93, 110, 133, 148, 159, 172, 183,
32894      &           207, 224, 241, 252, 268 /
32895       DATA IEII/ 0, 21, 46, 71, 92, 109, 126, 143, 160, 173, 186, 199,
32896      &           220, 241, 262, 279, 296 /
32897       DATA IRII/ 0, 315, 965, 1615, 1930, 2117, 2406, 2797, 3052, 3195,
32898      &           3364, 3507, 4011, 4368, 4725, 4912, 5184/
32899
32900 C
32901 C     MASSES FOR THE SLOPE B(M) IN GEV
32902 C     SLOPE B(M) FOR AN MESONIC SYSTEM
32903 C     SLOPE B(M) FOR A BARYONIC SYSTEM
32904
32905 *
32906       DATA SM,BBM,BBB/  0.8D0, 0.85D0,  0.9D0, 0.95D0, 1.D0,
32907      &     1.05D0,  1.1D0, 1.15D0,  1.2D0, 1.25D0,
32908      &      1.3D0,  1.35D0, 1.4D0,  1.45D0,  1.5D0,
32909      &     1.55D0,  1.6D0,  1.65D0, 1.7D0,   1.75D0,
32910      &      1.8D0,  1.85D0, 1.9D0,  1.95D0,  2.D0,
32911      &     15.6D0, 14.95D0, 14.3D0, 13.65D0, 13.D0,
32912      &    12.35D0, 11.7D0, 10.85D0, 10.D0,  9.15D0,
32913      &      8.3D0,  7.8D0,  7.3D0,  7.25D0,  7.2D0,
32914      &     6.95D0,  6.7D0,  6.6D0,  6.5D0,   6.3D0,
32915      &      6.1D0,  5.85D0, 5.6D0,  5.35D0,  5.1D0,
32916      &      15.D0,   15.D0, 15.D0,  15.D0,   15.D0, 15.D0, 15.D0,
32917      &     14.2D0,  13.4D0, 12.6D0,
32918      &     11.8D0, 11.2D0, 10.6D0,  9.8D0,    9.D0,
32919      &     8.25D0,  7.5D0, 6.25D0,  5.D0,    4.5D0, 5*4.D0 /
32920 *
32921       END
32922
32923 *$ CREATE DT_DAMG.FOR
32924 *COPY DT_DAMG
32925 *
32926 *===damg===============================================================*
32927 *
32928       DOUBLE PRECISION FUNCTION DT_DAMG(IT)
32929
32930       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32931       SAVE
32932
32933 * particle properties (BAMJET index convention),
32934 * (dublicate of DTPART for HADRIN)
32935       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32936      &                K1H(110),K2H(110)
32937
32938       DIMENSION GASUNI(14)
32939       DATA GASUNI/
32940      *-1.D0,-.98D0,-.95D0,-.87D0,-.72D0,-.48D0,
32941      *-.17D0,.17D0,.48D0,.72D0,.87D0,.95D0,.98D0,1.D0/
32942       DATA GAUNO/2.352D0/
32943       DATA GAUNON/2.4D0/
32944       DATA IO/14/
32945       DATA NSTAB/23/
32946
32947       I=1
32948       IF (IT.LE.0)                                              GO TO 30
32949       IF (IT.LE.NSTAB)                                          GO TO 20
32950       DGAUNI=GAUNO*GAUNON/DBLE(IO-1)
32951       VV=DT_RNDM(DGAUNI)
32952       VV=VV*2.0D0-1.0D0+1.D-16
32953    10 CONTINUE
32954       VO=GASUNI(I)
32955       I=I+1
32956       V1=GASUNI(I)
32957       IF (VV.GT.V1)                                             GO TO 10
32958       UNIGA=DGAUNI*(DBLE(I)-2.0D0+(VV-VO+1.D-16)/
32959      &      (V1-VO)-(DBLE(IO)-1.0D0)*0.5D0)
32960       DAM=GAH(IT)*UNIGA/GAUNO
32961       AAM=AMH(IT)+DAM
32962       DT_DAMG=AAM
32963       RETURN
32964    20 CONTINUE
32965       DT_DAMG=AMH(IT)
32966       RETURN
32967    30 CONTINUE
32968       DT_DAMG=0.0D0
32969       RETURN
32970       END
32971
32972 *$ CREATE DT_DCALUM.FOR
32973 *COPY DT_DCALUM
32974 *
32975 *===dcalum=============================================================*
32976 *
32977       SUBROUTINE DT_DCALUM(N,ITTA)
32978
32979       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
32980       SAVE
32981
32982 C*** C.M.S.-ENERGY AND REACTION CHANNEL THRESHOLD CALCULATION
32983
32984 * particle properties (BAMJET index convention),
32985 * (dublicate of DTPART for HADRIN)
32986       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
32987      &                K1H(110),K2H(110)
32988
32989       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
32990
32991       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
32992
32993       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
32994      &                NRK(2,268),NURE(30,2)
32995
32996       IRE=NURE(N,ITTA/8+1)
32997       IEO=IEII(IRE)+1
32998       IEE=IEII(IRE +1)
32999       AM1=AMH(N   )
33000       AM12=AM1**2
33001       AM2=AMH(ITTA)
33002       AM22=AM2**2
33003       DO 10 IE=IEO,IEE
33004         PLAB2=PLABF(IE)**2
33005         ELAB=SQRT(AM12+AM22+2.0D0*SQRT(PLAB2+AM12)*AM2)
33006         UMO(IE)=ELAB
33007    10 CONTINUE
33008       IKO=IKII(IRE)+1
33009       IKE=IKII(IRE +1)
33010       UMOO=UMO(IEO)
33011       DO 30 IK=IKO,IKE
33012         IF(NRK(2,IK).GT.0)                                      GO TO 30
33013         IKI=NRK(1,IK)
33014         AMSS=5.0D0
33015         K11=K1H(IKI)
33016         K22=K2H(IKI)
33017         DO 20 IK1=K11,K22
33018           IN=NZKI(IK1,1)
33019           AMS=AMH(IN)
33020           IN=NZKI(IK1,2)
33021           IF(IN.GT.0)AMS=AMS+AMH(IN)
33022           IN=NZKI(IK1,3)
33023           IF(IN.GT.0) AMS=AMS+AMH(IN)
33024           IF (AMS.LT.AMSS) AMSS=AMS
33025    20   CONTINUE
33026         IF(UMOO.LT.AMSS) UMOO=AMSS
33027         THRESH(IK)=UMOO
33028    30 CONTINUE
33029       RETURN
33030       END
33031
33032 *$ CREATE DT_DCHANH.FOR
33033 *COPY DT_DCHANH
33034 *
33035 *===dchanh=============================================================*
33036 *
33037       SUBROUTINE DT_DCHANH
33038
33039       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33040       SAVE
33041
33042       PARAMETER ( LINP = 10 ,
33043      &            LOUT = 6 ,
33044      &            LDAT = 9 )
33045
33046 * particle properties (BAMJET index convention),
33047 * (dublicate of DTPART for HADRIN)
33048       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33049      &                K1H(110),K2H(110)
33050
33051       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33052
33053       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33054
33055       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33056      &                NRK(2,268),NURE(30,2)
33057
33058       DIMENSION HWT(460),HWK(40),SI(5184)
33059       EQUIVALENCE (WK(1),SI(1))
33060 C--------------------
33061 C*** USE ONLY FOR DATAPREPARATION OF PURE HADRIN
33062 C*** CALCULATION OF REACTION- AND DECAY-CHANNEL-WEIGHTS,
33063 C*** THRESHOLD ENERGIES+MOMENTA OF REACTION CHNLS.
33064 C*** CHANGE OF WT- AND WK-INPUTDATA INTO WEIGHTS FOR THE M.-C.-PROCEDURE
33065 C*** (ADDED ONE TO EACH OTHER FOR CORRESPONDING CHANNELS)
33066 C--------------------------
33067       IREG=16
33068       DO 90 IRE=1,IREG
33069         IWKO=IRII(IRE)
33070         IEE=IEII(IRE+1)-IEII(IRE)
33071         IKE=IKII(IRE+1)-IKII(IRE)
33072         IEO=IEII(IRE)+1
33073         IIKA=IKII(IRE)
33074 *   modifications to suppress elestic scattering  24/07/91
33075         DO 80 IE=1,IEE
33076           SIS=1.D-14
33077           SINORC=0.0D0
33078           DO 10 IK=1,IKE
33079             IWK=IWKO+IEE*(IK-1)+IE
33080             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33081             SIS=SIS+SI(IWK)*SINORC
33082    10     CONTINUE
33083           SIIN(IEO+IE-1)=SIS
33084           SIO=0.D0
33085           IF (SIS.GE.1.D-12)                                    GO TO 20
33086           SIS=1.D0
33087           SIO=1.D0
33088    20     CONTINUE
33089           SINORC=0.0D0
33090           DO 30 IK=1,IKE
33091             IWK=IWKO+IEE*(IK-1)+IE
33092             IF(NRK(2,IIKA+IK).EQ.0) SINORC=1.0D0
33093             SIO=SIO+SI(IWK)*SINORC/SIS
33094             HWK(IK)=SIO
33095    30     CONTINUE
33096           DO 40 IK=1,IKE
33097             IWK=IWKO+IEE*(IK-1)+IE
33098    40     WK(IWK)=HWK(IK)
33099           IIKI=IKII(IRE)
33100           DO 70 IK=1,IKE
33101             AM111=0.D0
33102             INRK1=NRK(1,IIKI+IK)
33103             IF (INRK1.GT.0) AM111=AMH(INRK1)
33104             AM222=0.D0
33105             INRK2=NRK(2,IIKI+IK)
33106             IF (INRK2.GT.0) AM222=AMH(INRK2)
33107             THRESH(IIKI+IK)=AM111 +AM222
33108             IF (INRK2-1.GE.0)                                   GO TO 60
33109             INRKK=K1H(INRK1)
33110             AMSS=5.D0
33111             INRKO=K2H(INRK1)
33112             DO 50 INRK1=INRKK,INRKO
33113               INZK1=NZKI(INRK1,1)
33114               INZK2=NZKI(INRK1,2)
33115               INZK3=NZKI(INRK1,3)
33116               IF (INZK1.LE.0.OR.INZK1.GT.110)                   GO TO 50
33117               IF (INZK2.LE.0.OR.INZK2.GT.110)                   GO TO 50
33118               IF (INZK3.LE.0.OR.INZK3.GT.110)                   GO TO 50
33119 C     WRITE (6,310)INRK1,INZK1,INZK2,INZK3
33120  1000 FORMAT (4I10)
33121               AMS=AMH(INZK1)+AMH(INZK2)
33122               IF (INZK3-1.GE.0) AMS=AMS+AMH(INZK3)
33123               IF (AMSS.GT.AMS) AMSS=AMS
33124    50       CONTINUE
33125             AMS=AMSS
33126             IF (AMS.LT.UMO(IEO)) AMS=UMO(IEO)
33127             THRESH(IIKI+IK)=AMS
33128    60       CONTINUE
33129    70     CONTINUE
33130    80   CONTINUE
33131    90 CONTINUE
33132       DO 100 J=1,460
33133   100 HWT(J)=0.D0
33134       DO 120 I=1,110
33135         IK1=K1H(I)
33136         IK2=K2H(I)
33137         HV=0.D0
33138         IF (IK2.GT.460)IK2=460
33139         IF (IK1.LE.0)IK1=1
33140         DO 110 J=IK1,IK2
33141           HV=HV+WTI(J)
33142           HWT(J)=HV
33143           JI=J
33144   110   CONTINUE
33145         IF (ABS(HV-1.0D0).GT.1.D-4) WRITE(LOUT,1010)I,JI,HV
33146  1010 FORMAT (35H ERROR IN HWT, FALSE USE OF CHANWH ,2I6,F10.2)
33147   120 CONTINUE
33148       DO 130 J=1,460
33149   130 WTI(J)=HWT(J)
33150       RETURN
33151       END
33152
33153 *$ CREATE DT_DHADDE.FOR
33154 *COPY DT_DHADDE
33155 *
33156 *===dhadde=============================================================*
33157 *
33158       SUBROUTINE DT_DHADDE
33159
33160       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33161       SAVE
33162
33163 * particle properties (BAMJET index convention)
33164       CHARACTER*8  ANAME
33165       COMMON /DTPART/ ANAME(210),AAM(210),GA(210),TAU(210),
33166      &                IICH(210),IIBAR(210),K1(210),K2(210)
33167
33168 * HADRIN: decay channel information
33169       PARAMETER (IDMAX9=602)
33170       CHARACTER*8 ZKNAME
33171       COMMON /HNDECH/ ZKNAME(IDMAX9),WT(IDMAX9),NZK(IDMAX9,3)
33172
33173 * particle properties (BAMJET index convention),
33174 * (dublicate of DTPART for HADRIN)
33175       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33176      &                K1H(110),K2H(110)
33177
33178       COMMON /HNSPLI/ WTI(460),NZKI(460,3)
33179
33180 * decay channel information for HADRIN
33181       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33182      &                K1Z(16),K2Z(16),WTZ(153),II22,
33183      &                NZK1(153),NZK2(153),NZK3(153)
33184
33185       DATA IRETUR/0/
33186
33187       IRETUR=IRETUR+1
33188       AMH(31)=0.48D0
33189       IF (IRETUR.GT.1) RETURN
33190       DO 10 I=1,94
33191         AMH(I)   = AAM(I)
33192         GAH(I)   = GA(I)
33193         TAUH(I)  = TAU(I)
33194         ICHH(I)  = IICH(I)
33195         IBARH(I) = IIBAR(I)
33196         K1H(I)   = K1(I)
33197         K2H(I)   = K2(I)
33198    10 CONTINUE
33199 **sr
33200 C     AMH(1)=0.93828D0
33201       AMH(1)=0.9383D0
33202 **
33203       AMH(2)=AMH(1)
33204       DO 20 I=26,30
33205         K1H(I)=452
33206         K2H(I)=452
33207    20 CONTINUE
33208       DO 30 I=1,307
33209         WTI(I)    = WT(I)
33210         NZKI(I,1) = NZK(I,1)
33211         NZKI(I,2) = NZK(I,2)
33212         NZKI(I,3) = NZK(I,3)
33213    30 CONTINUE
33214       DO 40 I=1,16
33215         L=I+94
33216         AMH(L)=AMZ(I)
33217         GAH( L)=GAZ(I)
33218         TAUH( L)=TAUZ(I)
33219         ICHH( L)=ICHZ(I)
33220         IBARH( L)=IBARZ(I)
33221         K1H( L)=K1Z(I)
33222         K2H( L)=K2Z(I)
33223    40 CONTINUE
33224       DO 50 I=1,153
33225         L=I+307
33226         WTI(L)    = WTZ(I)
33227         NZKI(L,3) = NZK3(I)
33228         NZKI(L,2) = NZK2(I)
33229         NZKI(L,1) = NZK1(I)
33230    50 CONTINUE
33231       RETURN
33232       END
33233
33234 *$ CREATE IDT_IEFUND.FOR
33235 *COPY IDT_IEFUND
33236 *
33237 *===iefund=============================================================*
33238 *
33239       INTEGER FUNCTION IDT_IEFUND(PL,IRE)
33240
33241       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33242       SAVE
33243
33244 C*****IEFUN CALCULATES A MOMENTUM INDEX
33245
33246       PARAMETER ( LINP = 10 ,
33247      &            LOUT = 6 ,
33248      &            LDAT = 9 )
33249
33250       COMMON /HNDRUN/ RUNTES,EFTES
33251
33252       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33253
33254       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33255      &                NRK(2,268),NURE(30,2)
33256
33257       IPLA=IEII(IRE)+1
33258      *+1
33259       IPLE=IEII(IRE+1)
33260       IF (PL.LT.0.)                                             GO TO 30
33261       DO 10 I=IPLA,IPLE
33262         J=I-IPLA+1
33263         IF (PL.LE.PLABF(I))                                     GO TO 60
33264    10 CONTINUE
33265       I=IPLE
33266       IF ( EFTES.GT.40.D0)                                      GO TO 20
33267       EFTES=EFTES+1.0D0
33268       WRITE(LOUT,1000)PL,J
33269    20 CONTINUE
33270                                                                 GO TO 70
33271    30 CONTINUE
33272       DO 40 I=IPLA,IPLE
33273         J=I-IPLA+1
33274         IF (-PL.LE.UMO(I))                                      GO TO 60
33275    40 CONTINUE
33276       I=IPLE
33277       IF ( EFTES.GT.40.D0)                                      GO TO 50
33278       EFTES=EFTES+1.0D0
33279       WRITE(LOUT,1000)PL,I
33280    50 CONTINUE
33281    60 CONTINUE
33282    70 CONTINUE
33283       IDT_IEFUND=I
33284       RETURN
33285  1000 FORMAT(14H PLAB OR -ECM=,E12.4,27H IS OUT OF CONSIDERED RANGE ,
33286      +7H IEFUN=,I5)
33287       END
33288
33289 *$ CREATE DT_DSIGIN.FOR
33290 *COPY DT_DSIGIN
33291 *
33292 *===dsigin=============================================================*
33293 *
33294       SUBROUTINE DT_DSIGIN(IRE ,PLAB,N,IE ,AMT ,AMN,ECM ,SI ,ITAR)
33295
33296       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33297       SAVE
33298
33299 * particle properties (BAMJET index convention),
33300 * (dublicate of DTPART for HADRIN)
33301       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33302      &                K1H(110),K2H(110)
33303
33304       COMMON /HNREDV/ THRESH(268),IRII(17),IKII(17),IEII(17)
33305
33306       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33307      &                NRK(2,268),NURE(30,2)
33308
33309       IE=IDT_IEFUND(PLAB,IRE)
33310       IF (IE.LE.IEII(IRE)) IE=IE+1
33311       AMT=AMH(ITAR)
33312       AMN=AMH(N)
33313       AMN2=AMN*AMN
33314       AMT2=AMT*AMT
33315       ECM=SQRT(AMN2+AMT2+2.0D0*AMT*SQRT(AMN2+PLAB**2))
33316 C*** INTERPOLATION PREPARATION
33317       ECMO=UMO(IE)
33318       ECM1=UMO(IE-1)
33319       DECM=ECMO-ECM1
33320       DEC=ECMO-ECM
33321       IIKI=IKII(IRE)+1
33322       EKLIM=-THRESH(IIKI)
33323       WOK=SIIN(IE)
33324       WDK=WOK-SIIN(IE-1)
33325       IF (ECM.GT.ECMO) WDK=0.0D0
33326 C*** INTERPOLATION IN CHANNEL WEIGHTS
33327       IELIM=IDT_IEFUND(EKLIM,IRE)
33328       DELIM=UMO(IELIM)+EKLIM
33329      *+1.D-16
33330       DETE=(ECM-(ECMO-EKLIM)*0.5D0)*2.0D0
33331       IF (DELIM*DELIM-DETE*DETE) 20,20,10
33332    10 DECC=DELIM
33333                                                                 GO TO 30
33334    20 DECC=DECM
33335    30 CONTINUE
33336       WKK=WOK-WDK*DEC/(DECC+1.D-9)
33337       IF (WKK.LT.0.0D0) WKK=0.0D0
33338       SI=WKK+1.D-12
33339       IF (-EKLIM.GT.ECM) SI=1.D-14
33340       RETURN
33341       END
33342
33343 *$ CREATE DT_DTCHOI.FOR
33344 *COPY DT_DTCHOI
33345 *
33346 *===dtchoi=============================================================*
33347 *
33348       SUBROUTINE DT_DTCHOI(T,P,PP,E,EE,I,II,N,AM1,AM2)
33349
33350       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33351       SAVE
33352
33353 C     ****************************
33354 C     TCHOIC CALCULATES A RANDOM VALUE
33355 C     FOR THE FOUR-MOMENTUM-TRANSFER T
33356 C     ****************************
33357
33358 * particle properties (BAMJET index convention),
33359 * (dublicate of DTPART for HADRIN)
33360       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33361      &                K1H(110),K2H(110)
33362
33363 * slope parameters for HADRIN interactions
33364       COMMON /HNSLOP/ SM(25),BBM(25),BBB(25)
33365
33366       AMA=AM1
33367       AMB=AM2
33368       IF (I.GT.30.AND.II.GT.30)                                 GO TO 20
33369       III=II
33370       AM3=AM2
33371       IF (I.LE.30)                                              GO TO 10
33372       III=I
33373       AM3=AM1
33374    10 CONTINUE
33375                                                                 GO TO 30
33376    20 CONTINUE
33377       III=II
33378       AM3=AM2
33379       IF (AMA.LE.AMB)                                           GO TO 30
33380       III=I
33381       AM3=AM1
33382    30 CONTINUE
33383       IB=IBARH(III)
33384       AMA=AM3
33385       K=INT((AMA-0.75D0)/0.05D0)
33386       IF (K-2.LT.0) K=1
33387       IF (K-26.GE.0) K=25
33388       IF (IB)50,40,50
33389    40 BM=BBM(K)
33390                                                                 GO TO 60
33391    50 BM=BBB(K)
33392    60 CONTINUE
33393 C     NORMALIZATION
33394       TMIN=-2.0D0*(E*EE-P*PP)+AMH(N)**2+AM1  **2
33395       TMAX=-2.0D0*(E*EE+P*PP)+AMH(N)**2+AM1  **2
33396       VB=DT_RNDM(TMIN)
33397 **sr test
33398 C     IF (VB.LT.0.2D0) BM=BM*0.1
33399 C    **0.5
33400       BM = BM*5.05D0
33401 **
33402       TMI=BM*TMIN
33403       TMA=BM*TMAX
33404       ETMA=0.D0
33405       IF (ABS(TMA).GT.120.D0)                                   GO TO 70
33406       ETMA=EXP(TMA)
33407    70 CONTINUE
33408       AN=(1.0D0/BM)*(EXP(TMI)-ETMA)
33409 C*** RANDOM CHOICE OF THE T - VALUE
33410       R=DT_RNDM(TMI)
33411       T=(1.0D0/BM)*LOG(ETMA+R*AN*BM)
33412       RETURN
33413       END
33414
33415 *$ CREATE DT_DTWOPA.FOR
33416 *COPY DT_DTWOPA
33417 *
33418 *===dtwopa=============================================================*
33419 *
33420       SUBROUTINE DT_DTWOPA(E1,E2,P1,P2,COD1,COD2,COF1,COF2,SIF1,SIF2,
33421      &IT1,IT2,UMOO,ECM,P,N,AM1,AM2)
33422
33423       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33424       SAVE
33425
33426 C     ******************************************************
33427 C     QUASI TWO PARTICLE PRODUCTION
33428 C     TWOPAR CALCULATES THE ENERGYS AND THE MOMENTA
33429 C     FOR THE CREATED PARTICLES OR RESONANCES IT1 AND IT2
33430 C     IN THE CM - SYSTEM
33431 C     COD1,COD2,COF1,COF2,SIF1,SIF2 ARE THE ANGLES FOR
33432 C     SPHERICAL COORDINATES
33433 C     ******************************************************
33434
33435 * particle properties (BAMJET index convention),
33436 * (dublicate of DTPART for HADRIN)
33437       COMMON /HNABLT/ AMH(110),GAH(110),TAUH(110),ICHH(110),IBARH(110),
33438      &                K1H(110),K2H(110)
33439
33440       AMA=AM1
33441       AMB=AM2
33442       AMA2=AMA*AMA
33443       E1=((UMOO-AMB)*(UMOO+AMB) + AMA2)/(2.0D0*UMOO)
33444       E2=UMOO - E1
33445       IF (E1.LT.AMA*1.00001D0) E1=AMA*1.00001D0
33446       AMTE=(E1-AMA)*(E1+AMA)
33447       AMTE=AMTE+1.D-18
33448       P1=SQRT(AMTE)
33449       P2=P1
33450 C     / P2 / = / P1 /  BUT OPPOSITE DIRECTIONS
33451 C     DETERMINATION  OF  THE ANGLES
33452 C     COS(THETA1)=COD1      COS(THETA2)=COD2
33453 C     SIN(PHI1)=SIF1        SIN(PHI2)=SIF2
33454 C     COS(PHI1)=COF1        COS(PHI2)=COF2
33455 C     PHI IS UNIFORMLY DISTRIBUTED IN ( 0,2*PI )
33456       CALL DT_DSFECF(COF1,SIF1)
33457       COF2=-COF1
33458       SIF2=-SIF1
33459 C     CALCULATION OF THETA1
33460       CALL DT_DTCHOI(TR,P,P1,ECM,E1,IT1,IT2,N,AM1,AM2)
33461       COD1=(TR-AMA2-AMH(N)*AMH(N)+2.0D0*ECM*E1)/(2.0D0*P*P1+1.D-18)
33462       IF (COD1.GT.0.9999999D0) COD1=0.9999999D0
33463       COD2=-COD1
33464       RETURN
33465       END
33466
33467 *$ CREATE DT_ZK.FOR
33468 *COPY DT_ZK
33469 *
33470 *===zk=================================================================*
33471 *
33472       BLOCK DATA DT_ZK
33473
33474       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33475       SAVE
33476
33477 * decay channel information for HADRIN
33478       COMMON /HNADDH/ AMZ(16),GAZ(16),TAUZ(16),ICHZ(16),IBARZ(16),
33479      &                K1Z(16),K2Z(16),WTZ(153),II22,
33480      &                NZK1(153),NZK2(153),NZK3(153)
33481
33482 * decay channel information for HADRIN
33483       CHARACTER*8 ANAMZ,ZKNAM4,ZKNAM5,ZKNAM6
33484       COMMON /HNADDN/ ANAMZ(16),ZKNAM4(9),ZKNAM5(90),ZKNAM6(54)
33485
33486 *     Particle masses in GeV                                           *
33487       DATA AMZ/ 3*2.2D0, 0.9576D0, 3*1.887D0, 2.4D0, 2.03D0, 2*1.44D0,
33488      &          2*1.7D0, 3*0.D0/
33489 *     Resonance width Gamma in GeV                                     *
33490       DATA GAZ/ 3*.2D0, .1D0, 4*.2D0, .18D0, 2*.2D0, 2*.15D0, 3*0.D0 /
33491 *     Mean life time in seconds                                        *
33492       DATA TAUZ / 16*0.D0 /
33493 *     Charge of particles and resonances                               *
33494       DATA ICHZ/ 0, 1, 3*0, 1, -1, 0, 1, -1, 0, 0, 1 , 3*0 /
33495 *     Baryonic charge                                                  *
33496       DATA IBARZ/ 2, 7*0, 1, -1, -1, 1, 1, 3*0 /
33497 *     First number of decay channels used for resonances               *
33498 *     and decaying particles                                           *
33499       DATA K1Z/ 308,310,313,317,322,365,393,421,425,434,440,446,449,
33500      &          3*460/
33501 *     Last number of decay channels used for resonances                *
33502 *     and decaying particles                                           *
33503       DATA K2Z/ 309,312,316,321,364,392,420,424,433,439,445,448,451,
33504      &          3*460/
33505 *     Weight of decay channel                                          *
33506       DATA WTZ/ .17D0, .83D0, 2*.33D0, .34D0, .17D0, 2*.33D0, .17D0,
33507      & .01D0, .13D0, .36D0, .27D0, .23D0, .0014D0, .0029D0, .0014D0,
33508      & .0029D0, 4*.0007D0, .0517D0, .0718D0, .0144D0, .0431D0, .0359D0,
33509      & .0718D0, .0014D0, .0273D0, .0014D0, .0431D0, 2*.0129D0, .0259D0,
33510      & .0517D0, .0359D0, .0014D0, 2*.0144D0, .0129D0, .0014D0, .0259D0,
33511      & .0359D0, .0072D0, .0474D0, .0948D0, .0259D0, .0072D0, .0144D0,
33512      & .0287D0, .0431D0, .0144D0, .0287D0, .0474D0, .0144D0, .0075D0,
33513      & .0057D0, .0019D0, .0038D0, .0095D0, 2*.0014D0, .0191D0, .0572D0,
33514      & .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0, .0686D0,.0172D0,
33515      & .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0, .0190D0,
33516      & .0057D0, .0019D0, .0038D0, .0095D0, .0014D0, .0014D0, .0191D0,
33517      & .0572D0, .1430D0, 2*.0029D0, 5*.0477D0, .0019D0, .0191D0,.0686D0,
33518      & .0172D0, .0095D0, .1888D0, .0172D0, .0191D0, .0381D0, 2*.0571D0,
33519      & .0190D0, 4*.25D0, 2*.2D0, .12D0, .1D0, .07D0, .07D0, .14D0,
33520      & 2*.05D0, .0D0, .3334D0, .2083D0, 2*.125D0, .2083D0, .0D0, .125D0,
33521      & .2083D0, .3334D0, .2083D0, .125D0, .3D0, .05D0, .65D0, .3D0,
33522      & .05D0, .65D0, 9*1.D0 /
33523 *     Particle numbers in decay channel                                *
33524       DATA NZK1/ 8, 1, 2, 9, 1, 2, 9, 2, 9, 7, 13, 31, 15, 24, 23, 13,
33525      & 23, 13, 2*23, 14, 13, 23, 31, 98, 2*33, 32, 23, 14, 13, 35, 2*23,
33526      & 14, 13, 33, 23, 98, 31, 23, 14, 13, 35, 2*33, 32, 23, 35, 33, 32,
33527      & 98, 5*35, 4*13, 23, 13, 98, 32, 33, 23, 13, 23, 13, 14, 13, 32,
33528      & 13, 98, 23, 13, 2*32, 13, 33, 32, 98, 2*35, 4*14, 23, 14, 98,
33529      & 2*34, 23, 14, 23, 2*14, 13, 34, 14, 98, 23, 14, 2*34, 14, 33, 32,
33530      & 98, 2*35, 104, 61, 105, 62, 1, 17, 21, 17, 22, 2*21, 22, 21, 2,
33531      & 67, 68, 69, 2, 2*9, 68, 69, 70, 2, 9, 2*24, 15, 2*25, 16, 9*0/
33532       DATA NZK2/ 2*8, 1, 8, 9, 2*8, 2*1, 7, 14, 13, 16, 25, 23, 14, 23,
33533      & 14, 31, 33, 32, 34, 35, 31, 23, 31, 33, 34, 31, 32, 34, 31, 33,
33534      & 32, 2*33, 35, 31, 33, 31, 33, 32, 34, 35, 31, 33, 34, 35, 31,
33535      & 4*33, 32, 3*35,  2*23, 13, 31, 32, 33, 13, 31, 32, 2*31, 32, 33,
33536      & 32, 32, 35, 31, 2*32, 33, 31, 33, 35, 33, 3*32, 35, 2*23, 14,
33537      & 31, 34, 33, 14, 31, 33, 2*31, 34, 32, 33, 34, 35, 31, 2*34, 33,
33538      & 31, 33, 35, 33, 2*34, 33, 35, 1, 2, 8, 9, 25, 13, 35, 2*32, 33,
33539      & 31, 13, 23, 31, 13, 23, 14, 79, 80, 31, 13, 23, 14, 78, 79, 8,
33540      & 1, 8, 1, 8, 1, 9*0 /
33541       DATA NZK3/ 23, 14, 2*13, 23, 13, 2*23, 14, 0, 7, 14, 4*0, 2*23,
33542      & 10*0, 33, 2*31, 0, 33, 34, 32, 34, 0, 35, 0, 31, 3*35, 0, 3*31,
33543      & 35, 31, 33, 34, 31, 33, 34, 31, 33, 35, 0, 23, 14, 6*0, 32, 3*33,
33544      & 32, 34, 0, 35, 0, 2*35, 2*31, 35, 32, 34, 31, 33, 32, 0, 23, 13,
33545      & 6*0, 34, 2*33, 34, 33, 34, 0, 35, 0,2*35, 2*31, 35, 2*34, 31,
33546      & 2*34, 25*0, 23, 2*14, 23, 2*13, 9*0 /
33547 *     Particle  names                                                  *
33548       DATA ANAMZ / 'NNPI', 'ANPPI', 'ANNPI', ' ETS  ',' PAP  ',' PAN  ',
33549      & 'APN', 'DEO   ', 'S+2030', 'AN*-14', 'AN*014','KONPI ','AKOPPI',
33550      & 3*'BLANK' /
33551 *     Name of decay channel                                            *
33552       DATA ZKNAM4/'NNPI0','PNPI-','APPPI+','ANNPI+','ANPPI0','APNPI+',
33553      & 'ANNPI0','APPPI0','ANPPI-'/
33554       DATA ZKNAM5/' GAGA ','P+P-GA','ETP+P-','K+K-  ','K0AK0 ',
33555      & ' POPO ',' P+P- ','POPOPO','P+P0P-','P0ET  ','&0R0  ','P-R+  ',
33556      & 'P+R-  ','POOM  ',' ETET ','ETSP0 ','R0ET  ',' R0R0 ','R+R-  ',
33557      & 'P0ETR0','P-ETR+','P+ETR-',' OMET ','P0R0R0','P0R+R-','P-R+R0',
33558      & 'P+R-R0','R0OM  ','P0ETOM','ETSR0 ','ETETET','P0R0OM','P-R+OM',
33559      & 'P+R-OM','OMOM  ','R0ETET','R0R0ET','R+R-ET','P0OMOM','OMETET',
33560      & 'R0R0R0','R+R0R-','ETSRET','OMR0R0','OMR+R-','OMOMET','OMOMR0',
33561      & 'OMOMOM',
33562      & ' P+PO ','P+POPO','P+P+P-','P+ET  ','P0R+  ','P+R0  ','ETSP+ ',
33563      & 'R+ET  ',' R0R+ ','POETR+','P+ETR0','POR+R-','P+R0R0','P-R+R+',
33564      & 'P+R-R+','R+OM  ','P+ETOM','ETSR+ ','POR+OM','P+R0OM','R+ETET',
33565      & 'R+R0ET','P+OMOM','R0R0R+','R+R+R-','ETSR+E','OMR+R0','OMOMR+',
33566      & 'P-PO  ','P-POPO','P-P-P+','P-ET  ','POR-  ','P-R0  ','ETSP- ',
33567      & 'R-ET  ','R-R0  ','POETR-','P-ETR0','POR-R0','P-R+R-','P-R0R0'/
33568       DATA ZKNAM6/'P+R-R-','R-OM  ','P-ETOM','ETSR- ','POR-OM','P-R0OM',
33569      & 'R-ETET','R-R0ET','P-OMOM','R0R0R-','R+R-R-','ETSR-E','OMR0R-',
33570      & 'OMOMR-', 'PAN-14','APN+14','NAN014','ANN014','PAKO  ','LPI+  ',
33571      & 'SI+OM','LAMRO+','SI0RO+','SI+RO0','SI+ETA','SI0PI+','SI+PI0',
33572      & 'APETA ','AN=P+ ','AN-PO ','ANOPO ','APRHOO','ANRHO-','ANETA ',
33573      & 'AN-P+ ','AN0PO ','AN+P- ','APRHO+','ANRHO0',
33574      & 'KONPIO','KOPPI-','K+NPI-','AKOPPO','AKONP+','K-PPI+',
33575      & 9*'BLANK'/
33576 *=                                               end*block.zk      *
33577       END
33578
33579 *$ CREATE DT_BLKD43.FOR
33580 *COPY DT_BLKD43
33581 *
33582 *===blkd43=============================================================*
33583 *
33584       BLOCK DATA DT_BLKD43
33585
33586       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
33587       SAVE
33588
33589 *
33590 *=== reac =============================================================*
33591 *
33592 *----------------------------------------------------------------------*
33593 *                                                                      *
33594 *     Created on 10 december 1991  by    Alfredo Ferrari & Paola Sala  *
33595 *                                                   Infn - Milan       *
33596 *                                                                      *
33597 *     Last change on 10-dec-91     by    Alfredo Ferrari               *
33598 *                                                                      *
33599 *     This is the original common reac of Hadrin                       *
33600 *                                                                      *
33601 *----------------------------------------------------------------------*
33602 *
33603
33604       COMMON /HNREAC/ UMO(296),PLABF(296),SIIN(296),WK(5184),
33605      &                NRK(2,268),NURE(30,2)
33606
33607       DIMENSION
33608      & UMOPI(92), UMOKC(68), UMOP(39), UMON(63), UMOK0(34),
33609      & PLAPI(92), PLAKC(68), PLAP(39), PLAN(63), PLAK0(34),
33610      & SPIKP1(315), SPIKPU(278), SPIKPV(372),
33611      & SPIKPW(278), SPIKPX(372), SPIKP4(315),
33612      & SPIKP5(187), SPIKP6(289),
33613      & SKMPEL(102), SPIKP7(289), SKMNEL(68), SPIKP8(187),
33614      & SPIKP9(143), SPIKP0(169), SPKPV(143),
33615      & SAPPEL(105), SPIKPE(399), SAPNEL(84), SPIKPZ(273),
33616      & SANPEL(84) , SPIKPF(273),
33617      & SPKP15(187), SPKP16(272),
33618      & NRKPI(164), NRKKC(132), NRKP(70), NRKN(116), NRKK0(54),
33619      & NURELN(60)
33620 *
33621        DIMENSION NRKLIN(532)
33622        EQUIVALENCE (NRK(1,1), NRKLIN(1))
33623        EQUIVALENCE (   UMO(  1),  UMOPI(1)), (   UMO( 93),  UMOKC(1))
33624        EQUIVALENCE (   UMO(161),   UMOP(1)), (   UMO(200),   UMON(1))
33625        EQUIVALENCE (   UMO(263),  UMOK0(1))
33626        EQUIVALENCE ( PLABF(  1),  PLAPI(1)), ( PLABF( 93),  PLAKC(1))
33627        EQUIVALENCE ( PLABF(161),   PLAP(1)), ( PLABF(200),   PLAN(1))
33628        EQUIVALENCE ( PLABF(263),  PLAK0(1))
33629        EQUIVALENCE (   WK(   1), SPIKP1(1)), (   WK( 316), SPIKPU(1))
33630        EQUIVALENCE (   WK( 594), SPIKPV(1)), (   WK( 966), SPIKPW(1))
33631        EQUIVALENCE (   WK(1244), SPIKPX(1)), (   WK(1616), SPIKP4(1))
33632        EQUIVALENCE (   WK(1931), SPIKP5(1)), (   WK(2118), SPIKP6(1))
33633        EQUIVALENCE (   WK(2407), SKMPEL(1)), (   WK(2509), SPIKP7(1))
33634        EQUIVALENCE (   WK(2798), SKMNEL(1)), (   WK(2866), SPIKP8(1))
33635        EQUIVALENCE (   WK(3053), SPIKP9(1)), (   WK(3196), SPIKP0(1))
33636        EQUIVALENCE (   WK(3365),  SPKPV(1)), (   WK(3508), SAPPEL(1))
33637        EQUIVALENCE (   WK(3613), SPIKPE(1)), (   WK(4012), SAPNEL(1))
33638        EQUIVALENCE (   WK(4096), SPIKPZ(1)), (   WK(4369), SANPEL(1))
33639        EQUIVALENCE (   WK(4453), SPIKPF(1)), (   WK(4726), SPKP15(1))
33640        EQUIVALENCE (   WK(4913), SPKP16(1))
33641        EQUIVALENCE (NRK(1,1), NRKLIN(1))
33642        EQUIVALENCE (NRKLIN(   1), NRKPI(1)), (NRKLIN( 165), NRKKC(1))
33643        EQUIVALENCE (NRKLIN( 297),  NRKP(1)), (NRKLIN( 367),  NRKN(1))
33644        EQUIVALENCE (NRKLIN( 483), NRKK0(1))
33645        EQUIVALENCE (NURE(1,1), NURELN(1))
33646 *
33647 **** pi- p data                                                        *
33648 **** pi+ n data                                                        *
33649       DATA PLAPI / 0.D0, .3D0, .5D0, .6D0, .7D0, .8D0, .9D0, .95D0,1.D0,
33650      & 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0,
33651      & 3.D0, 3.5D0, 4.D0, 0.D0, .285D0, .4D0, .45D0, .5D0, .6D0, .7D0,
33652      & .75D0, .8D0, .85D0, .9D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0,
33653      & 1.8D0, 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0,
33654      & .285D0, .4D0, .45D0, .5D0, .6D0, .7D0, .75D0, .8D0, .85D0, .9D0,
33655      & 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0, 2.D0, 2.3D0, 2.5D0,
33656      & 2.8D0, 3.D0, 3.5D0, 4.D0, 4.5D0, 0.D0, .3D0, .5D0, .6D0, .7D0,
33657      & .8D0, .9D0, .95D0, 1.D0, 1.15D0, 1.3D0, 1.5D0, 1.6D0, 1.8D0,
33658      & 2.D0, 2.3D0, 2.5D0, 2.8D0, 3.D0, 3.5D0, 4.D0 /
33659       DATA PLAKC /
33660      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33661      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33662      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33663      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33664      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33665      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33666      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33667      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33668      & 3.51D0, 3.84D0, 4.16D0, 4.49D0,
33669      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33670      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33671      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33672       DATA PLAK0 /
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      &   0.D0,  .58D0,   .8D0, 1.01D0, 1.23D0, 1.45D0, 1.68D0, 1.94D0,
33677      & 2.18D0, 2.42D0, 2.68D0, 2.96D0, 3.24D0,
33678      & 3.51D0, 3.84D0, 4.16D0, 4.49D0/
33679 *                 pp   pn   np   nn                                    *
33680       DATA PLAP /
33681      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33682      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33683      &   0.D0, 1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33684      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
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 *    app   apn   anp   ann                                             *
33688       DATA PLAN /
33689      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
33690      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33691      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33692      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
33693      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33694      & 3.43D0, 3.75D0, 4.07D0, 4.43D0,
33695      &  0.D0,   1.D-3,   .1D0,   .2D0,   .3D0,  .4D0,  .5D0, .6D0,
33696      & .74D0,  1.06D0, 1.34D0, 1.63D0, 1.92D0, 2.2D0, 2.5D0,2.8D0,3.1D0,
33697      & 3.43D0, 3.75D0, 4.07D0, 4.43D0  /
33698       DATA SIIN / 296*0.D0 /
33699       DATA UMOPI/ 1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33700      & 1.557D0,1.615D0,1.6435D0,
33701      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33702      & 2.286D0,2.366D0,2.482D0,2.56D0,
33703      & 2.735D0,2.90D0,
33704      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33705      & 1.496D0,1.527D0,1.557D0,
33706      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33707      & 2.071D0,2.159D0,2.286D0,2.366D0,
33708      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33709      &             1.08D0,1.222D0,1.302D0,1.3365D0,1.369D0,1.434D0,
33710      & 1.496D0,1.527D0,1.557D0,
33711      & 1.586D0,1.615D0,1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,
33712      & 2.071D0,2.159D0,2.286D0,2.366D0,
33713      & 2.482D0,2.560D0,2.735D0,2.90D0,3.06D0,
33714      &                   1.08D0,1.233D0,1.302D0,1.369D0,1.496D0,
33715      & 1.557D0,1.615D0,1.6435D0,
33716      & 1.672D0,1.753D0,1.831D0,1.930D0,1.978D0,2.071D0,2.159D0,
33717      & 2.286D0,2.366D0,2.482D0,2.56D0,
33718      &  2.735D0, 2.90D0/
33719       DATA UMOKC/ 1.44D0,
33720      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33721      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33722      & 3.1D0,1.44D0,
33723      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33724      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33725      & 3.1D0,1.44D0,
33726      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33727      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33728      & 3.1D0,1.44D0,
33729      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33730      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33731      &  3.1D0/
33732       DATA UMOK0/ 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,1.44D0,
33736      &  1.598D0,1.7D0,1.8D0,1.9D0,2.0D0,2.1D0,2.2D0,2.3D0,2.4D0,2.5D0,
33737      & 2.6D0,2.7D0,2.8D0,2.9D0,3.0D0,
33738      &  3.1D0/
33739 *                 pp   pn   np   nn                                    *
33740       DATA UMOP/
33741      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33742      & 3.D0,3.1D0,3.2D0,
33743      & 1.88D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33744      & 3.D0,3.1D0,3.2D0,
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 *    app   apn   anp   ann                                             *
33748       DATA UMON /
33749      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33750      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33751      & 3.D0,3.1D0,3.2D0,
33752      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33753      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33754      & 3.D0,3.1D0,3.2D0,
33755      & 1.877D0,1.87701D0,1.879D0,1.887D0,1.9D0,1.917D0,1.938D0,1.962D0,
33756      & 2.D0,2.102D0,2.2D0,2.3D0,2.4D0,2.5D0,2.6D0,2.7D0,2.8D0,2.9D0,
33757      &  3.D0,3.1D0,3.2D0/
33758 **** reaction channel state particles                                  *
33759       DATA NRKPI / 13, 1, 15, 21, 81, 0, 13, 54, 23, 53, 13, 63, 13, 58,
33760      & 23, 57, 13, 65, 1, 32, 53, 31, 54, 32, 53, 33, 53, 35, 63, 32,
33761      & 13, 8, 23, 1, 17, 15, 21, 24, 22, 15, 82, 0, 61, 0, 13, 55, 23,
33762      & 54, 14, 53, 13, 64, 23, 63, 13, 59, 23, 58, 14, 57, 13, 66, 23,
33763      & 65, 1, 31, 8, 32, 1, 33, 1, 35, 54, 31, 55, 32, 54, 33, 53, 34,
33764      & 54, 35, 14, 1, 23, 8, 17, 24, 20, 15, 22, 24, 83, 0, 62, 0, 14,
33765      & 54, 23, 55, 13, 56, 14, 63, 23, 64, 14, 58, 23, 59, 13, 60, 14,
33766      & 65, 23, 66, 8, 31, 1, 34, 8, 33, 8, 35, 55, 31, 54, 34, 55, 33,
33767      & 56, 32, 55, 35, 14, 8, 24, 20, 84, 0, 14, 55, 23, 56, 14, 64, 14,
33768      & 59, 23, 60, 14, 66, 8, 34, 56, 31, 55, 34, 56, 33, 56, 35, 64,34/
33769       DATA NRKKC/ 15, 1, 89, 0, 24, 53, 15, 54, 1, 36, 1, 40, 1, 44, 36,
33770      & 63, 15, 63, 45, 53, 44, 54, 15, 8, 24, 1, 91, 0, 24, 54, 15, 55,
33771      & 8, 36, 1, 37, 8, 40, 1, 41, 8, 44, 1, 45, 36, 64, 37, 63, 15, 64,
33772      & 24, 63, 45, 54, 44, 55, 16, 1, 25, 8, 17, 23, 21, 14, 20,
33773      & 13, 22, 23, 90, 0, 38, 1, 39, 8, 16, 54, 25, 55, 1, 42, 8, 43,
33774      & 16, 63, 25, 64, 39, 64, 38, 63, 46, 54, 47, 55, 8, 47, 1, 46, 52,
33775      & 0, 51, 0, 16, 8, 17, 14, 20, 23, 22, 14, 92, 0, 8, 38, 16, 55,
33776      & 25, 56, 8, 42, 16, 64, 38, 64, 46, 55, 47, 56, 8, 46, 94, 0 /
33777 *                                                                      *
33778 *   k0 p   k0 n   ak0 p   ak/ n                                        *
33779 *                                                                      *
33780       DATA NRKK0 / 24, 8, 106, 0, 15, 56, 24, 55, 37, 8, 41, 8, 45, 8,
33781      & 37, 64, 24, 64, 44, 56, 45, 55, 25, 1, 17, 13,   22, 13, 21, 23,
33782      & 107, 0, 39, 1, 25, 54, 16, 53, 43, 1, 25, 63, 39, 63, 47, 54, 46,
33783      & 53, 47, 1, 103, 0, 93, 0/
33784 *   pp  pn   np   nn                                                   *
33785       DATA NRKP / 1, 1, 85, 0, 8, 53, 1, 54, 1, 63, 8, 57, 1, 58, 2*54,
33786      & 53, 55, 63, 54, 64, 53, 1, 8, 86, 0, 8, 54, 1, 55, 8, 63, 1, 64,
33787      & 8, 58, 1, 59, 64, 54, 63, 55, 54, 55, 53, 56, 77, 0, 2*8, 95, 0,
33788      & 8, 55, 1, 56, 8, 64, 8, 59, 1, 60, 2*55, 54, 56, 64, 55, 63, 56 /
33789 *     app   apn   anp   ann                                            *
33790       DATA NRKN/ 1, 2, 17, 18, 15, 16, 8, 9, 13, 14, 99, 0, 87, 0, 1,
33791      & 68, 8, 69, 2, 54, 9, 55, 102, 0, 2, 63, 9, 64, 1, 75, 8, 76, 53,
33792      & 67, 54, 68, 55, 69, 56, 70, 63, 68, 64, 69, 75, 54, 76, 55, 2, 8,
33793      & 18, 20, 16, 24, 14, 23, 101, 0, 88, 0, 2, 55, 9, 56, 1, 67, 8,
33794      & 68, 2, 64, 8, 75, 2, 59, 8, 72, 68, 55, 67, 54, 69, 56, 1, 9, 18,
33795      & 21, 15, 25, 13, 23, 100, 0, 96, 0, 2, 53, 9, 54, 1, 69, 8, 70, 1,
33796      & 76, 9, 63, 1, 73, 9, 58, 55, 70, 53, 68, 54, 69 /
33797 **** channel cross section                                             *
33798       DATA SPIKP1/ 0.D0, 300.D0, 40.D0, 20.D0, 13.D0,8.5D0,8.D0, 9.5D0,
33799      & 12.D0,14.D0,15.5D0,20.D0,17.D0,13.D0,10.D0,9.D0,8.5D0,8.D0,7.8D0,
33800      & 7.3D0, 6.7D0, 9*0.D0,.23D0,.35D0,.7D0,.52D0,.4D0,.3D0,.2D0,.15D0,
33801      & .13D0, .11D0, .09D0, .07D0, 0.D0, .033D0,.8D0,1.35D0,1.35D0,.5D0,
33802      & 15*0.D0, 3*0.D0,.00D0,0.80D0,2.2D0,3.6D0,4.6D0,4.7D0,3.5D0,2.4D0,
33803      &1.8D0,1.4D0,.75D0,.47D0,.25D0,.13D0,.08D0,6*0.D0,0.D0,1.2D0,3.3D0,
33804      & 5.4D0,6.9D0,7.3D0,5.3D0,3.6D0,2.7D0,2.2D0,1.1D0,.73D0,.4D0,.22D0,
33805      & .12D0,9*0.D0,.0D0,0.D0,2.0D0,4.4D0,6.8D0,9.9D0,7.9D0,6.0D0,3.8D0,
33806      &2.5D0,2.D0,1.4D0,1.D0,.6D0,.35D0,10*0.D0,.25D0,.55D0,.75D0,1.25D0,
33807      & 1.9D0,2.D0,1.8D0,1.5D0,1.25D0,1.D0,.8D0,6*0.D0,4*0.D0,.4D0,.85D0,
33808      & 1.1D0, 1.85D0, 2.8D0, 3.D0,2.7D0,2.2D0,1.85D0,1.5D0,1.2D0,6*0.D0,
33809      & 6*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0, 5.6D0,
33810      & 5.2D0, 6*0.D0, 2*0.D0, .0D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0,
33811      & 2.75D0, 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 6*0.D0, 3*0.D0,
33812      & .0D0, .45D0, 1.4D0, 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0,
33813      & 8*0.D0, 5*0.D0, .0D0, .0D0, .6D0, .8D0, .95D0, .8D0, .7D0, .6D0,
33814      & .5D0, .4D0, 6*0.D0, 5*0.D0, .0D0, .00D0, .85D0, 1.2D0, 1.4D0,
33815      & 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 6*0.D0, 5*0.D0, .0D0, .00D0,
33816      & 1.D0, 1.5D0, 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 6*0.D0,
33817      & 10*0.D0, .5D0, 2.0D0, 3.3D0, 5.4D0, 7.D0 /
33818 **** pi+ n data                                                        *
33819       DATA SPIKPU/   0.D0, 25.D0, 13.D0,  11.D0, 10.5D0, 14.D0,  20.D0,
33820      & 20.D0, 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33821      & 10.D0, 10.D0, 9.5D0,  9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33822      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0,   5.5D0,  4.8D0,
33823      & 4.2D0, 7.5D0, 3.4D0,  2.5D0, 2.5D0, 2.1D0, 1.4D0,   1.D0,   .8D0,
33824      &  .6D0, .46D0,  .3D0, .2D0, .15D0, .13D0, 11*0.D0,  .95D0,  .65D0,
33825      & .48D0, .35D0,  .2D0, .18D0, .17D0, .16D0,  .15D0,   .1D0,  .09D0,
33826      & .065D0, .05D0, .04D0, 12*0.D0, .2D0, .25D0, .25D0,  .2D0,   .1D0,
33827      & .08D0, .06D0, .045D0,   .03D0, .02D0, .01D0,      .005D0, .003D0,
33828      & 12*0.D0, .3D0, .24D0,   .18D0, .15D0, .13D0,  .12D0, .11D0, .1D0,
33829      & .09D0,  .08D0, .05D0,   .04D0, .03D0,  0.D0, 0.16D0, .7D0, 1.3D0,
33830      & 3.1D0,  4.5D0,  2.D0, 18*0.D0, 3*.0D0,  0.D0, 0.D0, 4.0D0, 11.D0,
33831      & 11.4D0, 10.3D0, 7.5D0, 6.8D0, 4.75D0, 2.5D0,  1.5D0, .9D0, .55D0,
33832      &  .35D0, 13*0.D0, .1D0, .34D0, .5D0, .8D0, 1.1D0,   2.25D0, 3.3D0,
33833      & 2.3D0, 1.6D0, .95D0, .45D0, .28D0, .15D0, 10*0.D0, 2*0.D0, .17D0,
33834      & .64D0,  1.D0, 1.5D0, 2.1D0, 4.25D0, 6.2D0,  4.4D0,   3.D0, 1.8D0,
33835      &  .9D0, .53D0, .28D0,      10*0.D0, 2*0.D0,  .25D0,  .82D0,
33836      & 1.3D0, 1.9D0, 2.8D0, 5.5D0 , 8.D0,  5.7D0, 3.9D0, 2.35D0, 1.15D0,
33837      & .69D0, .37D0, 10*0.D0,     7*0.D0,   .0D0, .34D0,  1.5D0, 3.47D0,
33838      & 5.87D0, 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0,  .3D0,  .15D0, 6*0.D0/
33839 *
33840       DATA SPIKPV/ 7*0.D0, .00D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33841      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 6*0.D0, 10*0.D0, .2D0,
33842      & .6D0, .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0,
33843      & 1.D0, .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0,
33844      & 3.5D0, 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0,
33845      & .31D0, .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0,
33846      & .23D0, 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0,
33847      & 5.D0, 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0,
33848      & 2.5D0, 3*0.D0, 3*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0,
33849      & 1.5D0, 1.1D0, .8D0, .7D0, .55D0, .3D0, 10*0.D0, 9*0.D0, .1D0,
33850      & .4D0, 1.D0, 1.4D0, 2.2D0, 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0,
33851      & .8D0, .6D0, .4D0, 12*0.D0, .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0,
33852      & 3.8D0, 3.3D0, 2.45D0, 2.05D0, 1.65D0, 1.2D0, .9D0, .6D0, 3*0.D0,
33853      & 9*0.D0, .10D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0,
33854      & 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0, 13*0.D0, .2D0, .5D0, .7D0,
33855      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33856      & 17*0.D0, .2D0, .5D0, .85D0, 2.D0, 2.15D0, 2.05D0, 1.75D0, 1.D0,
33857      & 17*0.D0, .13D0, .33D0, .57D0, 1.33D0, 1.43D0, 1.36D0, 1.17D0,
33858      & .67D0, 17*0.D0, .07D0, .17D0, .28D0, .67D0, .72D0, .69D0, .58D0,
33859      & .33D0,17*0.D0,.4D0, .7D0, 1.D0, 1.6D0, 1.8D0, 2.3D0,1.9D0,1.7D0 /
33860 **** pi- p data                                                        *
33861       DATA SPIKPW/ 0.D0, 25.D0, 13.D0, 11.D0, 10.5D0, 14.D0, 2*20.D0,
33862      & 16.D0, 14.D0, 19.D0, 28.D0, 17.5D0, 13.5D0, 12.D0, 10.5D0,
33863      & 2*10.D0, 9.5D0, 9.D0, 8.D0, 7.5D0, 7.D0, 6.5D0, 6.D0, 0.D0,
33864      & 48.D0, 19.D0, 15.D0, 11.5D0, 10.D0, 8.D0, 6.5D0, 5.5D0, 4.8D0,
33865      & 4.2D0, 7.5D0, 3.4D0, 2*2.5D0, 2.1D0, 1.4D0, 1.D0, .8D0, .6D0,
33866      & .46D0, .3D0, .2D0, .15D0, .13D0, 11*0.D0, .95D0, .65D0, .48D0,
33867      & .35D0, .2D0, .18D0, .17D0, .16D0, .15D0, .1D0, .09D0, .065D0,
33868      & .05D0, .04D0, 12*0.D0, .2D0, 2*.25D0, .2D0, .1D0, .08D0, .06D0,
33869      & .045D0, .03D0, .02D0, .01D0, .005D0, .003D0, 12*0.D0, .3D0,
33870      & .24D0, .18D0, .15D0, .13D0, .12D0, .11D0, .1D0, .09D0, .08D0,
33871      & .05D0, .04D0, .03D0, 0.D0, 0.16D0, .7D0, 1.3D0, 3.1D0, 4.5D0,
33872      & 2.D0, 23*0.D0, 4.0D0, 11.D0, 11.4D0, 10.3D0, 7.5D0, 6.8D0,
33873      & 4.75D0, 2.5D0, 1.5D0, .9D0, .55D0, .35D0, 13*0.D0, .1D0, .34D0,
33874      & .5D0, .8D0, 1.1D0, 2.25D0, 3.3D0, 2.3D0, 1.6D0, .95D0, .45D0,
33875      & .28D0, .15D0, 12*0.D0, .17D0, .64D0, 1.D0, 1.5D0, 2.1D0, 4.25D0,
33876      & 6.2D0, 4.4D0, 3.D0, 1.8D0, .9D0, .53D0, .28D0, 12*0.D0, .25D0,
33877      & .82D0, 1.3D0, 1.9D0, 2.8D0, 5.5D0, 8.D0, 5.7D0, 3.9D0, 2.35D0,
33878      & 1.15D0, .69D0, .37D0, 18*0.D0, .34D0, 1.5D0, 3.47D0, 5.87D0,
33879      & 6.23D0, 4.27D0, 2.6D0, 1.D0, .6D0, .3D0, .15D0, 6*0.D0/
33880 *
33881       DATA SPIKPX/ 8*0.D0, .16D0, .75D0, 1.73D0, 2.93D0, 3.12D0,
33882      & 2.13D0, 1.3D0, .5D0, .3D0, .15D0, .08D0, 16*0.D0, .2D0, .6D0,
33883      & .92D0, 2.4D0, 4.9D0, 6.25D0, 5.25D0, 3.5D0, 2.15D0, 1.4D0, 1.D0,
33884      & .7D0, 13*0.D0, .13D0, .4D0, .62D0, 1.6D0, 3.27D0, 4.17D0, 3.5D0,
33885      & 2.33D0, 1.43D0, .93D0, .66D0, .47D0, 13*0.D0, .07D0, .2D0, .31D0,
33886      & .8D0, 1.63D0, 2.08D0, 1.75D0, 1.17D0, .72D0, .47D0, .34D0, .23D0,
33887      & 17*0.D0, .33D0, 1.D0, 1.8D0, 2.67D0, 5.33D0, 6.D0, 5.53D0, 5.D0,
33888      & 17*0.D0, .17D0, .5D0, .9D0, 1.83D0, 2.67D0, 3.0D0, 2.77D0, 2.5D0,
33889      & 6*0.D0, 1.D0, 3.3D0, 2.8D0, 2.5D0, 2.3D0, 1.8D0, 1.5D0, 1.1D0,
33890      & .8D0, .7D0, .55D0, .3D0, 19*0.D0, .1D0, .4D0, 1.D0, 1.4D0, 2.2D0,
33891      & 2.5D0, 2.2D0, 1.65D0, 1.35D0, 1.1D0, .8D0, .6D0, .4D0, 12*0.D0,
33892      & .15D0, .6D0, 1.5D0, 2.1D0, 3.3D0, 3.8D0, 3.3D0, 2.45D0, 2.05D0,
33893      & 1.65D0, 1.2D0, .9D0, .6D0, 12*0.D0, .10D0, .2D0, .5D0, .7D0,
33894      & 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0, 1.35D0, 1.15D0, .95D0, .7D0,
33895      & 13*0.D0, .2D0, .5D0, .7D0, 1.3D0, 1.55D0, 1.9D0, 1.8D0, 1.55D0,
33896      & 1.35D0, 1.15D0, .95D0, .7D0, 17*0.D0, .2D0, .5D0, .85D0, 2.D0,
33897      & 2.15D0, 2.05D0, 1.75D0, 1.D0, 17*0.D0, .13D0, .33D0, .57D0,
33898      & 1.33D0, 1.43D0, 1.36D0, 1.17D0, .67D0, 17*0.D0, .07D0, .17D0,
33899      & .28D0, .67D0, .72D0, .69D0, .58D0, .33D0, 17*0.D0, .4D0, .7D0,
33900      & 1.D0, 1.6D0, 1.8D0, 2.3D0, 1.9D0, 1.7D0 /
33901 **** pi- n data                                                        *
33902       DATA SPIKP4 / 0.D0, 300.D0, 40.D0, 20.D0, 13.D0, 8.5D0, 8.D0,
33903      & 9.5D0, 12.D0, 14.D0, 15.5D0, 20.D0, 17.D0, 13.D0, 10.D0, 9.D0,
33904      & 8.5D0, 8.D0, 7.8D0, 7.3D0, 6.7D0, 9*0.D0, .23D0, .35D0, .7D0,
33905      & .52D0, .4D0, .3D0, .2D0, .15D0, .13D0, .11D0, .09D0, .07D0, 0.D0,
33906      & .033D0, .8D0, 2*1.35D0, .5D0, 19*0.D0, 0.8D0, 2.2D0, 3.6D0,
33907      & 4.6D0, 4.7D0, 3.5D0, 2.4D0, 1.8D0, 1.4D0, .75D0, .47D0, .25D0,
33908      & .13D0, .08D0, 7*0.D0, 1.2D0, 3.3D0, 5.4D0, 6.9D0, 7.3D0, 5.3D0,
33909      & 3.6D0, 2.7D0, 2.2D0, 1.1D0, .73D0, .4D0, .22D0, .12D0, 11*0.D0,
33910      & 2.0D0, 4.4D0, 6.8D0, 9.9D0, 7.9D0, 6.0D0, 3.8D0, 2.5D0, 2.D0,
33911      & 1.4D0, 1.D0, .6D0, .35D0, 10*0.D0, .25D0, .55D0, .75D0, 1.25D0,
33912      & 1.9D0, 2.D0, 1.8D0, 1.5D0, 1.25D0, 1.D0, .8D0, 10*0.D0, .4D0,
33913      & .85D0, 1.1D0, 1.85D0, 2.8D0, 3.D0, 2.7D0, 2.2D0, 1.85D0, 1.5D0,
33914      & 1.2D0, 12*0.D0, .5D0, 1.2D0, 1.7D0, 3.4D0, 5.2D0, 6.4D0, 6.1D0,
33915      & 5.6D0, 5.2D0, 9*0.D0, 1.D0, 3.3D0, 5.2D0, 4.45D0, 3.6D0, 2.75D0,
33916      & 1.9D0, 1.65D0, 1.3D0, .95D0, .6D0, .45D0, 10*0.D0, .45D0, 1.4D0,
33917      & 1.5D0, 1.1D0, .85D0, .5D0, .3D0, .2D0, .15D0, 15*0.D0, .6D0,
33918      & .8D0, .95D0, .8D0, .7D0, .6D0, .5D0, .4D0, 13*0.D0, .85D0, 1.2D0,
33919      & 1.4D0, 1.2D0, 1.05D0, .9D0, .7D0, .55D0, 13*0.D0, 1.D0, 1.5D0,
33920      & 3.5D0, 4.15D0, 3.7D0, 2.7D0, 2.3D0, 1.75D0, 16*0.D0, .5D0, 2.0D0,
33921      & 3.3D0, 5.4D0, 7.D0 /
33922 **** k+  p data                                                        *
33923       DATA SPIKP5/ 0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0,
33924      & 7.D0, 6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
33925      & 0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 13*0.D0, 0.9D0,
33926      & 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0,
33927      & .45D0, .21D0, .2D0, 3*0.D0, .9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33928      & 2.D0, 1.7D0, 1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
33929      & 4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0, 1.4D0,
33930      & 1.2D0, 1.05D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0, 2*1.D0, .9D0,
33931      & .7D0, .4D0, .3D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.2D0,
33932      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33933      & 1.71D0, 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0,
33934      & 3.5D0, 2.85D0, 2.35D0, 2.01D0, 1.8D0, 12*0.D0, .1D0, .8D0,2.05D0,
33935      & 3.31D0, 3.5D0, 12*0.D0, .034D0, .2D0, .75D0, 1.04D0, 1.24D0 /
33936 **** k+  n data                                                        *
33937       DATA SPIKP6/ 0.D0, 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0,
33938      & 1.5D0, 1.2D0, 1.D0, .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0,
33939      & 6.D0, 11.D0, 13.D0, 6.D0, 5.D0, 3.D0, 2.2D0, 1.5D0, 1.2D0, 1.D0,
33940      & .7D0, .6D0, .5D0, .45D0, .35D0, .3D0, 0.D0, .5D0, 1.3D0, 2.8D0,
33941      & 2.3D0, 1.6D0, .9D0, 13*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0,
33942      & 2.D0, 1.7D0, 1.5D0,1.2D0,.9D0,.6D0,.45D0,.21D0,.2D0,3*0.D0,0.9D0,
33943      & 2.5D0, 3.D0, 2.5D0, 2.3D0,2.D0,1.7D0,1.5D0,1.2D0,.9D0,.6D0,.45D0,
33944      & .21D0, .2D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.D0,1.8D0,1.7D0,1.4D0,
33945      & 1.2D0,1.15D0,.9D0,.66D0,.5D0,4*0.D0,1.D0,2.1D0,2.6D0,2.3D0,2.1D0,
33946      & 1.8D0,1.7D0,1.4D0,1.2D0, 1.15D0, .9D0, .66D0, .5D0, 7*0.D0, .3D0,
33947      & 2*1.D0, .9D0, .7D0, .4D0, .35D0, .2D0, 9*0.D0, .3D0, 2*1.D0,.9D0,
33948      & .7D0, .4D0, .35D0, .2D0, 11*0.D0, .1D0, 1.D0, 2.4D0,3.5D0,4.25D0,
33949      & 4.55D0, 4.85D0, 4.9D0, 9*0.D0, .1D0, 1.D0, 2.4D0, 3.5D0, 4.25D0,
33950      & 4.55D0, 4.85D0, 4.9D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0,
33951      & 1.71D0, 1.6D0, 10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0,
33952      & 1.6D0, 6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0,4.4D0,4.D0,3.5D0,2.85D0,
33953      & 2.35D0, 2.01D0, 1.8D0, 6*0.D0, 1.4D0,3.8D0,5.D0,4.7D0,4.4D0,4.D0,
33954      & 3.5D0,2.85D0,2.35D0,2.01D0,1.8D0,12*0.D0,.1D0,.8D0,2.05D0,3.31D0,
33955      & 3.5D0, 12*0.D0, .034D0,.2D0,.75D0,1.04D0,1.24D0 /
33956 **** k-  p data                                                        *
33957       DATA SKMPEL/ 0.D0, 35.D0, 22.D0, 25.D0, 17.D0, 9.D0, 9.5D0, 8.D0,
33958      &     7.D0, 6.5D0, 6.1D0, 5.D0, 4.8D0, 4.6D0, 4.45D0, 4.3D0, 4.2D0,
33959      &    0.D0, 8.D0, 3.5D0, 8.D0, 3.D0, 1.9D0, 1.7D0, 1.D0, .9D0, .8D0,
33960      &    .75D0, .5D0, .42D0, .38D0, .34D0, .25D0, .2D0,
33961      &    0.D0, 3.D0, 3.2D0, 3.5D0, 1.5D0, 1.4D0, 1.1D0, .6D0, .5D0,
33962      &    .35D0, .28D0, .25D0, .18D0, .12D0, .1D0, .08D0, .04D0,
33963      &    0.D0, 8.5D0, 2.4D0, 1.7D0, 1.3D0, 1.3D0, 1.1D0, .5D0,
33964      &    .4D0, .4D0, .35D0, .3D0, .28D0, .2D0, .16D0, .13D0, .11D0,
33965      &    0.D0, 7.D0, 4.8D0, 1.4D0, 1.9D0, .9D0, .4D0, .2D0, .13D0,
33966      &    .1D0, .08D0, .06D0, .04D0, .02D0, .015D0, .01D0, .01D0,
33967      &    0.D0, 5.5D0, 1.D0, .8D0, .75D0, .32D0, .2D0, .1D0, .09D0,
33968      &    .08D0, .065D0, .05D0, .04D0, .022D0, .017D0, 2*.01D0/
33969       DATA SPIKP7 / 0.D0, .56D0, 1.46D0, 3.16D0, 2.01D0, 1.28D0, .74D0,
33970      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
33971      & 1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 4*0.D0,
33972      & 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0, 1.57D0,
33973      & 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,  3*0.D0, 1.0D0, 3.03D0,
33974      & 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0,
33975      & .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0, 2.8D0,
33976      & 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0,
33977      & .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
33978      & .45D0, .39D0, .22D0, .07D0, 0.D0, 7*0.D0, .34D0, 1.12D0, 1.12D0,
33979      & 1.01D0, .78D0, .45D0, .39D0, .22D0, .07D0, 0.D0, 6*0.D0, 1.71D0,
33980      & 4.26D0, 5.6D0, 5.57D0, 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0,
33981      & 2.25D0, 2.D0, 6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
33982      & 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0, .22D0,
33983      & .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 10*0.D0, .22D0, .8D0,
33984      & .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0, .3D0, .7D0,1.D0,
33985      & 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0, 1.72D0, 2.69D0,
33986      & 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 9*0.D0, .11D0, 1.72D0,
33987      & 2.69D0, 3.92D0, 4.76D0, 5.1D0, 5.44D0, 5.3D0, 5*0.D0,9.2D0,4.7D0,
33988      & 1.9D0, 10*0.D0, 2.5D0, 15.D0, 21.5D0, 15.3D0, 3.D0, 1.5D0,
33989      & 10*0.D0/
33990 ***** k- n data                                                        *
33991       DATA SKMNEL/0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
33992      &        3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0,
33993      &        0.D0, 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0,
33994      &        1.9D0, .9D0, .5D0, .3D0, .24D0, .2D0, .18D0, .1D0, .09D0,
33995      &        0.D0, 1.8D0, 2.D0, 1.1D0, .9D0, .5D0, .5D0, .4D0, .4D0,
33996      &        .2D0, .1D0, .06D0, .05D0, .04D0, .03D0, .02D0, .02D0,
33997      &        0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0, .7D0, .65D0,
33998      &       .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0, .03D0/
33999       DATA SPIKP8/0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34000      &  14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0,
34001      &  1.91D0, 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0,
34002      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
34003      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
34004      &  3*0.D0, 1.D0, 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0,
34005      &  1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0, .5D0, .24D0, .23D0,
34006      &  7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0, .45D0,
34007      &  .39D0, .22D0, .07D0, 0.D0,
34008      &  6*0.D0, 1.71D0, 4.26D0, 5.6D0, 5.57D0, 4.93D0,
34009      &  4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0,
34010      &  10*0.D0, .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0,
34011      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34012      &  13*0.D0, .1D0, .3D0, .7D0, 1.D0,
34013      &  9*0.D0, .11D0, 1.72D0, 2.69D0, 3.92D0, 4.76D0,
34014      &  5.10D0, 5.44D0, 5.3D0,
34015      &  4*0.D0, 0.00D0, 9.2D0, 4.7D0, 1.9D0, 9*0.D0/
34016 *****  p p data                                                        *
34017       DATA SPIKP9/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34018      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34019      &              0.D0, 3.6D0, 1.7D0, 10*0.D0,
34020      &              .0D0, 0.D0, 8.7D0, 17.7D0, 18.8D0, 15.9D0,
34021      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34022      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34023      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34024      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34025      &              16.9D0, 16.5D0, 11.D0, 5.5D0, 3.5D0,
34026      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
34027      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
34028      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34029      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34030      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34031      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34032 *****  p n data                                                        *
34033       DATA SPIKP0/ 0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34034      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34035      &              0.D0, 1.8D0, .2D0,  12*0.D0,
34036      &              3.2D0, 6.05D0, 9.9D0, 5.1D0,
34037      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34038      &              2*.0D0, 3.2D0, 6.05D0, 9.9D0, 5.1D0,
34039      &              3.8D0, 2.7D0, 1.9D0, 1.5D0, 1.4D0, 1.3D0, 1.1D0,
34040      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34041      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34042      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0,
34043      &              16.4D0, 15.2D0, 11.D0, 5.4D0, 3.5D0,
34044      &              10*0.D0, .7D0, 5.1D0, 8.D0,
34045      &              10*0.D0, .7D0, 5.1D0, 8.D0,
34046      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
34047      &              10*.0D0, .3D0, 2.8D0, 4.7D0,
34048      &              7*0.D0, 1.2D0, 2.5D0, 3.5D0, 6.D0, 5.3D0, 2.9D0,
34049      &              7*0.D0, 1.7D0, 3.6D0, 5.4D0, 9.D0, 7.6D0, 4.2D0,
34050      &              5*0.D0, 7.7D0, 6.1D0, 2.9D0, 5*0.D0/
34051 *   nn - data                                                          *
34052 *                                                                      *
34053       DATA SPKPV/  0.D0, 24.D0, 25.D0, 27.D0, 23.D0, 21.D0, 20.D0,
34054      &              19.D0, 17.D0, 15.5D0, 14.D0, 13.5D0, 13.D0,
34055      &              0.D0, 3.6D0, 1.7D0, 12*0.D0,
34056      &              8.7D0, 17.7D0, 18.8D0, 15.9D0,
34057      &              11.7D0, 8.D0, 6.D0, 5.3D0, 4.5D0, 3.9D0, 3.5D0,
34058      &              .0D0, .0D0, 2.8D0, 5.8D0, 6.2D0, 5.1D0, 3.8D0,
34059      &              2.7D0, 2.1D0, 1.8D0, 1.5D0, 1.3D0, 1.1D0,
34060      &              5*0.D0, 4.6D0, 10.2D0, 15.1D0, 16.9D0, 16.5D0,
34061      &              11.D0, 5.5D0, 3.5D0,
34062      &              10*0.D0, 4.3D0, 7.6D0, 9.D0,
34063      &              10*0.D0, 1.7D0, 2.6D0, 3.D0,
34064      &              6*0.D0, .3D0, .6D0, 1.D0, 1.6D0, 1.3D0, .8D0, .6D0,
34065      &              6*0.D0, .7D0, 1.2D0, 1.8D0, 2.5D0, 1.8D0, 1.3D0,
34066      &              1.2D0, 10*0.D0, .6D0, 1.4D0, 1.7D0,
34067      &              10*0.D0, 1.9D0, 4.1D0, 5.2D0/
34068 ****************   ap - p - data                                       *
34069       DATA SAPPEL/ 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0,
34070      &  50.D0,  50.D0, 43.D0, 42.D0, 40.5D0, 35.D0, 30.D0, 28.D0,
34071      &  25.D0,  22.D0, 21.D0, 20.D0, 18.D0, 17.D0,  11*0.D0,
34072      &  .05D0,  .15D0, .18D0, .2D0, .2D0, .3D0, .4D0, .6D0, .7D0, .85D0,
34073      &  0.D0,  1.D0, .9D0, .46D0, .3D0, .23D0, .18D0, .16D0, .14D0,
34074      &  .1D0,  .08D0, .05D0, .02D0, .015D0, 4*.011D0, 3*.005D0,
34075      &  0.D0,  55.D0, 50.D0, 25.D0, 15.D0, 15.D0, 14.D0, 12.D0,
34076      &  10.D0,  7.D0, 6.D0, 4.D0, 3.3D0, 2.8D0, 2.4D0, 2.D0, 1.8D0,
34077      &  1.55D0,  1.3D0, .95D0, .75D0,
34078      &  0.D0,  3.3D0, 3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0,
34079      &  .25D0,  .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34080      & .01D0,  .008D0, .006D0, .005D0/
34081       DATA SPIKPE/0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34082      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34083      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0,
34084      & 9*0.D0, 2.D0, 2.5D0, .2D0, 19*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0,
34085      & 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0, .3D0, 1.4D0,
34086      & 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0, .3D0, 10*0.D0,
34087      & .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0, .6D0, .5D0, .4D0,
34088      & .3D0, 10*0.D0, .3D0, 1.4D0, 2.2D0, 1.2D0, 1.1D0, 1.D0, .8D0,
34089      & .6D0, .5D0, .4D0, .3D0, 9*0.D0, .6D0, 2.5D0, 5.D0, 5.2D0, 5.1D0,
34090      & 5.4D0, 5.8D0, 2.8D0, 2.1D0, 1.8D0, 1.6D0, 1.2D0, 13*0.D0, 1.3D0,
34091      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34092      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34093      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 13*0.D0, 1.3D0,
34094      & 1.5D0, 2.D0, 2.5D0, 2.5D0, 2.3D0, 1.8D0, 1.4D0, 14*0.D0, .2D0,
34095      & .5D0, 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0,
34096      & 1.1D0, 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0,
34097      & 1.6D0, 1.4D0, 1.1D0, .9D0, 14*0.D0, .2D0, .5D0, 1.1D0, 1.6D0,
34098      & 1.4D0, 1.1D0, .9D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0,
34099      & .3D0, 1.6D0, 2.6D0, 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0,
34100      & 3.6D0, 17*0.D0, .3D0, 1.6D0, 2.6D0, 3.6D0 /
34101 ****************   ap - n - data                                       *
34102       DATA SAPNEL/
34103      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0,  68.D0, 65.D0,
34104      & 50.D0, 50.D0,  43.D0,  42.D0,  40.5D0, 35.D0, 30.D0,  28.D0,
34105      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0,  17.D0, 11*0.D0,
34106      & .05D0, .15D0, .18D0,  .2D0,    .2D0,  .3D0,  .4D0,   .6D0,  .7D0,
34107      & .85D0,  0.D0,  1.D0,  .9D0,    .46D0, .3D0,  .23D0, .18D0, .16D0,
34108      & .14D0,  .1D0, .08D0, .05D0,    .02D0, .015D0, 4*.011D0, 3*.005D0,
34109      & 0.D0,  3.3D0,  3.D0, 1.5D0,     1.D0, .7D0,  .4D0,  .35D0, .4D0,
34110      & .25D0, .18D0, .08D0, .04D0,    .03D0, .023D0, .016D0, .014D0,
34111      & .01D0, .008D0, .006D0, .005D0 /
34112        DATA SPIKPZ/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34113      &  84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34114      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34115      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34116      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34117      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34118      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34119      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34120      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34121      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34122      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34123      & 4.9D0, 8.5D0,  15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34124      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34125      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34126 *                                                                      *
34127 *                                                                      *
34128 ****************   an - p - data                                       *
34129 *                                                                      *
34130       DATA SANPEL/
34131      & 0.D0,  176.D0, 160.D0, 105.D0, 75.D0, 68.D0, 65.D0, 50.D0,
34132      & 50.D0, 43.D0,  42.D0,  40.5D0, 35.D0, 30.D0, 28.D0,
34133      & 25.D0, 22.D0,  21.D0,  20.D0,  18.D0, 17.D0, 11*0.D0, .05D0,
34134      & .15D0, .18D0,   .2D0,   .2D0,   .3D0,  .4D0, .6D0,   .7D0, .85D0,
34135      & 0.D0,   1.D0,   .9D0,  .46D0,  .3D0,  .23D0, .18D0, .16D0, .14D0,
34136      & .1D0,  .08D0,  .05D0,  .02D0, .015D0, 4*.011D0, 3*.005D0,
34137      & 0.D0,  3.3D0,  3.D0, 1.5D0, 1.D0, .7D0, .4D0, .35D0, .4D0, .25D0,
34138      & .18D0, .08D0, .04D0, .03D0, .023D0, .016D0, .014D0,
34139      & .01D0, .008D0, .006D0, .005D0 /
34140       DATA SPIKPF/ 0.D0, 215.D0, 193.D0, 170.D0, 148.D0, 113.D0, 97.D0,
34141      & 84.D0, 78.D0, 68.D0, 64.D0, 61.D0, 46.D0, 36.D0, 31.3D0, 28.5D0,
34142      & 25.7D0, 22.6D0, 21.4D0, 20.7D0, 19.9D0, 9*0.D0, 2.4D0, .2D0,
34143      & 20*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34144      & .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0,
34145      & 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0, 10*0.D0, 1.8D0, 2.8D0,
34146      & 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0, .7D0, .5D0, .3D0,
34147      & 10*0.D0, 1.8D0, 2.8D0, 3.6D0, 2.3D0, 1.8D0, 1.5D0, 1.3D0, 1.D0,
34148      & .7D0, .5D0, .3D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34149      & 7.6D0, 6.D0, 5.D0, 13*0.D0, 5.2D0, 8.7D0, 11.4D0, 14.D0, 11.9D0,
34150      & 7.6D0, 6.D0, 5.D0, 18*0.D0, 1.D0, 4.9D0, 8.5D0, 18*0.D0, 1.D0,
34151      & 4.9D0, 8.5D0, 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0,
34152      & 15*0.D0, 1.9D0, 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0, 15*0.D0, 1.9D0,
34153      & 2.3D0, 4.D0, 6.5D0, 5.2D0, 3.4D0 /
34154 ****  ko - n - data                                                    *
34155       DATA SPKP15/0.D0, 20.D0, 14.D0, 12.D0, 11.5D0, 10.D0, 8.D0, 7.D0,
34156      &      6.D0, 5.5D0, 5.3D0, 5.D0, 4.5D0, 4.4D0, 3.8D0, 3.D0, 2.8D0,
34157      &      0.D0, .5D0, 1.15D0, 2.D0, 1.3D0, .8D0, .45D0, 10*0.D0,
34158      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34159      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34160      &    3*0.D0, 0.9D0, 2.5D0, 3.D0, 2.5D0, 2.3D0, 2.D0, 1.7D0,
34161      &     1.5D0, 1.2D0, .9D0, .6D0, .45D0, .21D0, .2D0,
34162      &    4*0.D0, 1.D0, 2.1D0, 2.6D0, 2.3D0, 2.1D0, 1.8D0, 1.7D0,
34163      &     1.4D0, 1.2D0, 1.05D0, .9D0, .66D0,  .5D0,
34164      &    7*0.D0, .3D0, 1.D0, 1.D0, .9D0, .7D0, .4D0, .30D0, .2D0,
34165      &   11*0.D0, .1D0, 1.D0, 2.2D0, 3.5D0, 4.20D0, 4.55D0,
34166      &    4.85D0, 4.9D0,
34167      &   10*0.D0, .2D0, .7D0, 1.6D0, 2.5D0, 2.2D0, 1.71D0, 1.6D0,
34168      &    6*0.D0, 1.4D0, 3.8D0, 5.D0, 4.7D0, 4.4D0, 4.D0, 3.5D0,
34169      &    2.85D0, 2.35D0, 2.01D0, 1.8D0,
34170      &   12*0.D0, .1D0, .8D0, 2.05D0, 3.31D0, 3.5D0,
34171      &   12*0.D0, .034D0, .20D0, .75D0, 1.04D0, 1.24D0  /
34172 **** ako - p - data                                                    *
34173       DATA SPKP16/ 0.D0, 4.D0, 9.5D0, 20.D0, 13.D0, 9.5D0, 6.D0, 4.4D0,
34174      & 3.D0, 2.4D0, 2.D0, 1.4D0, 1.2D0, 1.D0, .9D0, .7D0, .6D0, 0.D0,
34175      & 4.5D0, 6.D0, 5.D0, 2.5D0, 2.D0, 1.7D0, 2.1D0, 1.9D0, .9D0, .5D0,
34176      & .3D0, .24D0, .2D0, .18D0, .1D0, .09D0, 0.D0, 1.8D0, 2.D0, 1.1D0,
34177      & .9D0, .5D0, .5D0, .4D0, .4D0, .2D0, .1D0, .06D0, .05D0, .04D0,
34178      & .03D0, .02D0, .02D0, 0.D0, 1.5D0, 2.D0, .9D0, 1.1D0, .4D0, .6D0,
34179      & .7D0, .65D0, .3D0, .17D0, .1D0, .08D0, .07D0, .06D0, .04D0,
34180      & .03D0, 0.D0, .56D0, 1.29D0, 2.26D0, 1.01D0, .64D0, .37D0,
34181      & 14*0.D0, 1.13D0, 2.61D0, 2.91D0, 2.58D0, 2.35D0, 2.02D0, 1.91D0,
34182      & 1.57D0, 1.35D0, 1.29D0, 1.01D0, .74D0, .65D0, 3*0.D0, 1.0D0,
34183      & 3.03D0, 3.36D0, 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0,
34184      & 1.01D0, .67D0, .5D0, .24D0, .23D0, 3*0.D0, 1.0D0, 3.03D0, 3.36D0,
34185      & 2.8D0, 2.58D0, 2.24D0, 1.91D0, 1.68D0, 1.35D0, 1.01D0, .67D0,
34186      & .5D0, .24D0, .23D0, 7*0.D0, .34D0, 1.12D0, 1.12D0, 1.01D0, .78D0,
34187      & .45D0, .39D0, .22D0, .07D0, 7*0.D0, 1.71D0, 4.26D0, 5.6D0,5.57D0,
34188      & 4.93D0, 4.48D0, 3.92D0, 3.19D0, 2.63D0, 2.25D0, 2.D0, 10*0.D0,
34189      & .22D0, .8D0, .75D0, 1.D0, 1.3D0, 1.5D0, 1.3D0, 13*0.D0, .1D0,
34190      & .3D0, .7D0, 1.D0, 13*0.D0, .1D0, .3D0, .7D0, 1.D0, 9*0.D0, .11D0,
34191      & 1.72D0, 2.69D0, 3.92D0, 4.76D0, 5.10D0, 5.44D0, 5.3D0, 5*0.D0,
34192      & 9.2D0, 4.7D0, 1.9D0, 9*0.D0, .0D0,2.5D0,15.D0,
34193      & 21.5D0, 15.3D0, 3.D0, 1.5D0, 10*0.D0 /
34194       DATA NURELN/9, 12, 5*0, 10, 14, 3*0, 1, 3, 5, 7, 6*0, 2, 6, 16,
34195      & 5*0, 10, 13, 5*0, 11, 12, 3*0, 2, 4, 6, 8, 6*0, 3, 15, 7, 5*0 /
34196 *=                                               end*block.blkdt3      *
34197       END
34198 *$ CREATE DT_QEL_POL.FOR
34199 *COPY DT_QEL_POL
34200 *
34201 *===qel_pol============================================================*
34202 *
34203       SUBROUTINE DT_QEL_POL(ENU,LTYP,P21,P22,P23,P24,P25)
34204
34205       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34206       SAVE
34207
34208       CALL DT_MASS_INI
34209       CALL DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34210
34211       RETURN
34212       END
34213
34214 *$ CREATE DT_GEN_QEL.FOR
34215 *COPY DT_GEN_QEL
34216 C==================================================================
34217 C   Generation of  a Quasi-Elastic neutrino scattering
34218 C==================================================================
34219 *
34220 *===gen_qel============================================================*
34221 *
34222       SUBROUTINE DT_GEN_QEL(ENU,LTYP,P21,P22,P23,P24,P25)
34223
34224 C...Generate a quasi-elastic   neutrino/antineutrino
34225 C.  Interaction on a nuclear target
34226 C.  INPUT  : LTYP = neutrino type (1,...,6)
34227 C.           ENU (GeV) = neutrino energy
34228 C----------------------------------------------------
34229
34230       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34231       SAVE
34232
34233       PARAMETER ( LINP = 10 ,
34234      &            LOUT = 6 ,
34235      &            LDAT = 9 )
34236       PARAMETER (MAXLND=4000)
34237       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34238
34239 * nuclear potential
34240       LOGICAL LFERMI
34241       COMMON /DTNPOT/ PFERMP(2),PFERMN(2),FERMOD,
34242      &                EBINDP(2),EBINDN(2),EPOT(2,210),
34243      &                ETACOU(2),ICOUL,LFERMI
34244
34245 * steering flags for qel neutrino scattering modules
34246       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34247 **sr - removed (not needed)
34248 C     COMMON /CBAD/  LBAD, NBAD
34249 C     COMMON /CNUC/ XMN,XMN2,PFERMI,EFERMI,EBIND,EB2,C0
34250 **
34251
34252       DIMENSION PI(3),PO(3)
34253 CJR+
34254       DATA ININU/0/
34255 CJR-
34256 C     REAL*8 DBETA(3)
34257 C     REAL*8 MN(2), ML0(6), ML, ML2, MI, MI2, MF, MF2
34258       DIMENSION DBETA(3),DBETB(3),AMN(2),AML0(6)
34259       DATA AMN  /0.93827231D0, 0.93956563D0/
34260       DATA AML0 /2*0.51100D-03,2*0.105659D0, 2*1.777D0/
34261       DATA INIPRI/0/
34262
34263 C     DATA PFERMI/0.22D0/
34264 CGB+...Binding Energy
34265       DATA EBIND/0.008D0/
34266 CGB-...
34267
34268       ININU=ININU+1
34269       IF(ININU.EQ.1)NDSIG=0
34270       LBAD = 0
34271       enu0=enu
34272 c      write(*,*) enu0
34273 C...Lepton mass
34274       AML = AML0(LTYP)       !  massa leptoni
34275       AML2 = AML**2          !  massa leptoni **2
34276 C...Particle labels (LUND)
34277       N = 5
34278       K(1,1) = 21
34279       K(2,1) = 21
34280       K(3,1) = 21
34281       K(3,3) = 1
34282       K(4,1) = 1
34283       K(4,3) = 1
34284       K(5,1) = 1
34285       K(5,3) = 2
34286       K0 = (LTYP-1)/2          !  2
34287       K1 = LTYP/2              !  2
34288       KA = 12 + 2*K0           !  16
34289       IS = -1 + 2*LTYP - 4*K1  !  -1 +10 -8 = 1
34290       K(1,2) = IS*KA
34291       K(4,2) = IS*(KA-1)
34292       K(3,2) = IS*24
34293       LNU = 2 - LTYP + 2*K1    !  2 - 5 + 2 = - 1
34294       IF (LNU .EQ. 2)  THEN
34295         K(2,2) = 2212
34296         K(5,2) = 2112
34297         AMI = AMN(1)
34298         AMF = AMN(2)
34299 CJR+
34300         PFERMI=PFERMN(2)
34301 CJR-
34302       ELSE
34303         K(2,2) = 2112
34304         K(5,2) = 2212
34305         AMI = AMN(2)
34306         AMF = AMN(1)
34307 CJR+
34308         PFERMI=PFERMP(2)
34309 CJR-
34310       ENDIF
34311       AMI2 = AMI**2
34312       AMF2 = AMF**2
34313
34314       DO IGB=1,5
34315         P(3,IGB) = 0.
34316         P(4,IGB) = 0.
34317         P(5,IGB) = 0.
34318       END DO
34319
34320       NTRY = 0
34321 CGB+...
34322       EFMAX  = SQRT(PFERMI**2 + AMI2) -AMI             ! max. Fermi Energy
34323       ENWELL = EFMAX + EBIND ! depth of nuclear potential well
34324 CGB-...
34325
34326   100 CONTINUE
34327
34328 C...4-momentum initial lepton
34329       P(1,5) = 0.     ! massa
34330       P(1,4) = ENU0    ! energia
34331       P(1,1) = 0.     ! px
34332       P(1,2) = 0.     ! py
34333       P(1,3) = ENU0    ! pz
34334
34335 C     PF = PFERMI*PYR(0)**(1./3.)
34336 c       write(23,*) PYR(0)
34337 c      write(*,*) 'Pfermi=',PF
34338 c      PF = 0.
34339       NTRY=NTRY+1
34340 C     IF(ntry.GT.2) WRITE(*,*) ntry,enu0,k2
34341       IF (NTRY .GT. 500)  THEN
34342         LBAD = 1
34343         WRITE (LOUT,1001)  NBAD, ENU
34344         RETURN
34345       ENDIF
34346 C     CT = -1. + 2.*PYR(0)
34347 c      CT = -1.
34348 C     ST =  SQRT(1.-CT*CT)
34349 C     F = 2.*3.1415926*PYR(0)
34350 c      F = 0.
34351
34352 C     P(2,4) = SQRT(PF*PF + MI2) - EBIND  ! energia
34353 C     P(2,1) = PF*ST*COS(F)               ! px
34354 C     P(2,2) = PF*ST*SIN(F)               ! py
34355 C     P(2,3) = PF*CT                      ! pz
34356 C     P(2,5) = SQRT(P(2,4)**2-PF*PF)      ! massa
34357        P(2,1) = P21
34358        P(2,2) = P22
34359        P(2,3) = P23
34360        P(2,4) = P24
34361        P(2,5) = P25
34362       beta1=-p(2,1)/p(2,4)
34363       beta2=-p(2,2)/p(2,4)
34364       beta3=-p(2,3)/p(2,4)
34365       N=2
34366 C      WRITE(6,*)' before transforming into target rest frame'
34367
34368       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
34369
34370 C      print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
34371       N=5
34372
34373       phi11=atan(p(1,2)/p(1,3))
34374       pi(1)=p(1,1)
34375       pi(2)=p(1,2)
34376       pi(3)=p(1,3)
34377
34378       CALL DT_TESTROT(PI,Po,PHI11,1)
34379       DO ll=1,3
34380         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34381       END DO
34382 c        WRITE(*,*) po
34383       p(1,1)=po(1)
34384       p(1,2)=po(2)
34385       p(1,3)=po(3)
34386       phi12=atan(p(1,1)/p(1,3))
34387
34388       pi(1)=p(1,1)
34389       pi(2)=p(1,2)
34390       pi(3)=p(1,3)
34391       CALL DT_TESTROT(Pi,Po,PHI12,2)
34392       DO ll=1,3
34393         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34394       END DO
34395 c        WRITE(*,*) po
34396       p(1,1)=po(1)
34397       p(1,2)=po(2)
34398       p(1,3)=po(3)
34399
34400       enu=p(1,4)
34401
34402 C...Kinematical limits in Q**2
34403 c      S = P(2,5)**2 + 2.*ENU*(P(2,4)-P(2,3)) !            ????
34404       S = P(2,5)**2 + 2.*ENU*P(2,5)
34405       SQS = SQRT(S)                          ! E centro massa
34406       IF (SQS .LT. (AML + AMF + 3.E-03)) GOTO 100
34407       ELF = (S-AMF2+AML2)/(2.*SQS)           ! energia leptone finale p
34408       PSTAR = (S-P(2,5)**2)/(2.*SQS)       ! p* neutrino nel c.m.
34409       PLF = SQRT(ELF**2-AML2)               ! 3-momento leptone finale
34410       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)    ! + o -
34411       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)    ! according con cos(theta)
34412       IF (Q2MIN .LT. 0.)   Q2MIN = 0.      ! ??? non fisico
34413
34414 C...Generate Q**2
34415       DSIGMAX = DT_DSQEL_Q2 (LTYP,ENU, Q2MIN)
34416   200 Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
34417       DSIG = DT_DSQEL_Q2 (LTYP,ENU, Q2)
34418       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
34419       CALL DT_QGAUS(Q2MIN,Q2MAX,DSIGEV,ENU,LTYP)
34420       NDSIG=NDSIG+1
34421 C     WRITE(6,*)' Q2,Q2min,Q2MAX,DSIGEV',
34422 C    &Q2,Q2min,Q2MAX,DSIGEV
34423
34424 C...c.m. frame. Neutrino along z axis
34425       DETOT = (P(1,4)) + (P(2,4)) ! e totale
34426       DBETA(1) = ((P(1,1)) + (P(2,1)))/DETOT ! px1+px2/etot = beta_x
34427       DBETA(2) = ((P(1,2)) + (P(2,2)))/DETOT !
34428       DBETA(3) = ((P(1,3)) + (P(2,3)))/DETOT !
34429 c      WRITE(*,*)
34430 c      WRITE(*,*)
34431 C      WRITE(*,*) 'Input values laboratory frame'
34432       N=2
34433
34434       CALL PYROBO(0,0,0.0D0,0.0D0,-DBETA(1),-DBETA(2),-DBETA(3))
34435
34436       N=5
34437 c      STHETA = ULANGL(P(1,3),P(1,1))
34438 c      write(*,*) 'stheta' ,stheta
34439 c      stheta=0.
34440 c      CALL PYROBO (0,0,-STHETA,0.,0.D0,0.D0,0.D0)
34441 c      WRITE(*,*)
34442 c      WRITE(*,*)
34443 C      WRITE(*,*) 'Output values cm frame'
34444 C...Kinematic in c.m. frame
34445       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF) ! cos(theta) cm
34446       STSTAR = SQRT(1.-CTSTAR**2)
34447       PHI = 6.28319*PYR(0) ! random phi tra 0 e 2*pi
34448       P(4,5) = AML                  ! massa leptone
34449       P(4,4) = ELF                 ! e leptone
34450       P(4,3) = PLF*CTSTAR          ! px
34451       P(4,1) = PLF*STSTAR*COS(PHI) ! py
34452       P(4,2) = PLF*STSTAR*SIN(PHI) ! pz
34453
34454       P(5,5) = AMF                  ! barione
34455       P(5,4) = (S+AMF2-AML2)/(2.*SQS)! e barione
34456       P(5,3) = -P(4,3)             ! px
34457       P(5,1) = -P(4,1)             ! py
34458       P(5,2) = -P(4,2)             ! pz
34459
34460       P(3,5) = -Q2
34461       P(3,1) = P(1,1)-P(4,1)
34462       P(3,2) = P(1,2)-P(4,2)
34463       P(3,3) = P(1,3)-P(4,3)
34464       P(3,4) = P(1,4)-P(4,4)
34465
34466 C...Transform back to laboratory  frame
34467 C      WRITE(*,*) 'before going back to nucl rest frame'
34468 c      CALL PYROBO (0,0,STHETA,0.,0.D0,0.D0,0.D0)
34469       N=5
34470
34471       CALL PYROBO(0,0,0.0D0,0.0D0,DBETA(1),DBETA(2),DBETA(3))
34472
34473 C      WRITE(*,*) 'Now back in nucl rest frame'
34474       IF(LTYP.GE.3) CALL DT_PREPOLA(Q2,LTYP,ENU)
34475
34476 c********************************************
34477
34478       DO kw=1,5
34479         pi(1)=p(kw,1)
34480         pi(2)=p(kw,2)
34481         pi(3)=p(kw,3)
34482         CALL DT_TESTROT(Pi,Po,PHI12,3)
34483         DO ll=1,3
34484           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34485         END DO
34486         p(kw,1)=po(1)
34487         p(kw,2)=po(2)
34488         p(kw,3)=po(3)
34489       END DO
34490 c********************************************
34491
34492       DO kw=1,5
34493         pi(1)=p(kw,1)
34494         pi(2)=p(kw,2)
34495         pi(3)=p(kw,3)
34496         CALL DT_TESTROT(Pi,Po,PHI11,4)
34497         DO ll=1,3
34498           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
34499         END DO
34500         p(kw,1)=po(1)
34501         p(kw,2)=po(2)
34502         p(kw,3)=po(3)
34503       END DO
34504
34505 c********************************************
34506
34507 C      WRITE(*,*) 'Now back in lab frame'
34508
34509       CALL PYROBO(1,5,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
34510
34511 CGB+...
34512 C...test (on final momentum of nucleon) if Fermi-blocking
34513 C...is operating
34514       ENUCL = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2 + P(5,5)**2)
34515      &  - P(5,5)
34516       IF (ENUCL.LT. EFMAX) THEN
34517         IF(INIPRI.LT.10)THEN
34518           INIPRI=INIPRI+1
34519 C         WRITE(6,*)' qel: Pauli ENUCL.LT.EFMAX ', ENUCL,EFMAX
34520 C...the interaction is not possible due to Pauli-Blocking and
34521 C...it must be resampled
34522         ENDIF
34523         GOTO 100
34524       ELSE IF (ENUCL.LT.ENWELL.and.ENUCL.GE.EFMAX) THEN
34525         IF(INIPRI.LT.10)THEN
34526           INIPRI=INIPRI+1
34527 C     WRITE(6,*)' qel: inside ENUCL.LT.ENWELL ', ENUCL,ENWELL
34528         ENDIF
34529 C                      Reject (J:R) here all these events
34530 C                      are otherwise rejected in dpmjet
34531         GOTO 100
34532 C...the interaction is possible, but the nucleon remains inside
34533 C...the nucleus. The nucleus is therefore left excited.
34534 C...We treat this case as a nucleon with 0 kinetic energy.
34535 C       P(5,5) = AMF
34536 C       P(5,4) = AMF
34537 C       P(5,1) = 0.
34538 C       P(5,2) = 0.
34539 C       P(5,3) = 0.
34540       ELSE IF (ENUCL.GE.ENWELL) THEN
34541 C     WRITE(6,*)' qel ENUCL.GE.ENWELL ',ENUCL,ENWELL
34542 C...the interaction is possible, the nucleon can exit the nucleus
34543 C...but the nuclear well depth must be subtracted. The nucleus could be
34544 C...left in an excited state.
34545         Pstart = SQRT(P(5,1)**2 + P(5,2)**2 + P(5,3)**2)
34546 C       P(5,4) = ENUCL-ENWELL + AMF
34547         Pnucl = SQRT(P(5,4)**2-AMF**2)
34548 C...The 3-momentum is scaled assuming that the direction remains
34549 C...unaffected
34550         P(5,1) = P(5,1) * Pnucl/Pstart
34551         P(5,2) = P(5,2) * Pnucl/Pstart
34552         P(5,3) = P(5,3) * Pnucl/Pstart
34553 C     WRITE(6,*)' qel new P(5,4) ',P(5,4)
34554       ENDIF
34555 CGB-...
34556       DSIGSU=DSIGSU+DSIGEV
34557
34558          GA=P(4,4)/P(4,5)
34559          BGX=P(4,1)/P(4,5)
34560          BGY=P(4,2)/P(4,5)
34561          BGZ=P(4,3)/P(4,5)
34562 *
34563          DBETB(1)=BGX/GA
34564          DBETB(2)=BGY/GA
34565          DBETB(3)=BGZ/GA
34566          IF(NEUDEC.EQ.1.OR.NEUDEC.EQ.2) THEN
34567
34568             CALL PYROBO(6,8,0.0D0,0.0D0,DBETB(1),DBETB(2),DBETB(3))
34569
34570          ENDIF
34571 c
34572 C      PRINT*,' FINE   EVENTO '
34573       enu=enu0
34574       RETURN
34575
34576  1001 FORMAT(2X, 'DT_GEN_QEL   : event rejected ', I5,  G10.3)
34577       END
34578
34579 *$ CREATE DT_MASS_INI.FOR
34580 *COPY DT_MASS_INI
34581 C====================================================================
34582 C.  Masses
34583 C====================================================================
34584 *
34585 *===mass_ini===========================================================*
34586 *
34587       SUBROUTINE DT_MASS_INI
34588 C...Initialize  the kinematics for the quasi-elastic cross section
34589
34590       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34591       SAVE
34592
34593 * particle masses used in qel neutrino scattering modules
34594       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34595      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34596      &                EMPROTSQ,EMNEUTSQ,EMNSQ
34597
34598       EML(1) = 0.51100D-03   ! e-
34599       EML(2) = EML(1)        ! e+
34600       EML(3) = 0.105659D0      ! mu-
34601       EML(4) = EML(3)        ! mu+
34602       EML(5) = 1.7777D0        ! tau-
34603       EML(6) = EML(5)        ! tau+
34604       EMPROT = 0.93827231D0    ! p
34605       EMNEUT = 0.93956563D0    ! n
34606       EMPROTSQ = EMPROT**2
34607       EMNEUTSQ = EMNEUT**2
34608       EMN = (EMPROT + EMNEUT)/2.
34609       EMNSQ = EMN**2
34610       DO J=1,3
34611         J0 = 2*(J-1)
34612         EMN1(J0+1) = EMNEUT
34613         EMN1(J0+2) = EMPROT
34614         EMN2(J0+1) = EMPROT
34615         EMN2(J0+2) = EMNEUT
34616       ENDDO
34617       DO J=1,6
34618         EMLSQ(J) = EML(J)**2
34619         ETQE(J)  = ((EMN2(J)+ EML(J))**2-EMN1(J)**2)/(2.*EMN1(J))
34620       ENDDO
34621       RETURN
34622       END
34623
34624 *$ CREATE DT_DSQEL_Q2.FOR
34625 *COPY DT_DSQEL_Q2
34626 *
34627 *===dsqel_q2===========================================================*
34628 *
34629       DOUBLE PRECISION FUNCTION DT_DSQEL_Q2 (JTYP,ENU, Q2)
34630
34631 C...differential cross section for  Quasi-Elastic scattering
34632 C.       nu + N -> l + N'
34633 C.  From Llewellin Smith  Phys.Rep.  3C, 261, (1971).
34634 C.
34635 C.  INPUT :  JTYP = 1,...,6    nu_e, ...., nubar_tau
34636 C.           ENU (GeV) =  Neutrino energy
34637 C.           Q2  (GeV**2) =  (Transfer momentum)**2
34638 C.
34639 C.  OUTPUT : DSQEL_Q2  = differential  cross section :
34640 C.                       dsigma/dq**2  (10**-38 cm+2/GeV**2)
34641 C------------------------------------------------------------------
34642
34643       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34644       SAVE
34645
34646 * particle masses used in qel neutrino scattering modules
34647       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34648      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34649      &                EMPROTSQ,EMNEUTSQ,EMNSQ
34650 **sr - removed (not needed)
34651 C     COMMON /CAXIAL/ FA0, AXIAL2
34652 **
34653
34654       DIMENSION SS(6)
34655       DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34656       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34657       DATA AXIAL2 /1.03D0/  ! to be checked
34658
34659       FA0=-1.253D0
34660       CSI = 3.71D0                   !  ???
34661       GVE = 1.D0/ (1.D0 + Q2/0.84D0**2)**2   ! G_e(q**2)
34662       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
34663       X = Q2/(EMN*EMN)     ! emn=massa barione
34664       XA = X/4.D0
34665       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34666       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34667       FA = FA0/(1.D0 + Q2/AXIAL2)**2
34668       FFA = FA*FA
34669       FFV1 = FV1*FV1
34670       FFV2 = FV2*FV2
34671       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
34672       A1 = (4.D0+X)*FFA - (4.D0-X)*FFV1 + X*FFV2*(1.D0-XA)+4*X*FV1*FV2
34673       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
34674       AA = (XA+0.25D0*RM)*(A1 + A2)
34675       BB = -X*FA*(FV1 + FV2)
34676       CC = 0.25D0*(FFA + FFV1 + XA*FFV2)
34677       SU = (4.D0*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34678       DT_DSQEL_Q2 = C0*(AA + SS(JTYP)*BB*SU + CC*SU*SU) / (ENU*ENU)  !
34679       IF(DT_DSQEL_Q2 .LT. 0.D0) DT_DSQEL_Q2 = 0.D0
34680
34681       RETURN
34682       END
34683
34684 *$ CREATE DT_PREPOLA.FOR
34685 *COPY DT_PREPOLA
34686 *
34687 *===prepola============================================================*
34688 *
34689       SUBROUTINE DT_PREPOLA(Q2,JTYP,ENU)
34690
34691       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34692       SAVE
34693 c
34694 c By G. Battistoni and E. Scapparone (sept. 1997)
34695 c According to:
34696 c     Albright & Jarlskog, Nucl Phys B84 (1975) 467
34697 c
34698 c
34699       PARAMETER (MAXLND=4000)
34700       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
34701
34702       COMMON /QNPOL/ POLARX(4),PMODUL
34703
34704 * particle masses used in qel neutrino scattering modules
34705       COMMON /QNMASS/ EML(6),EMLSQ(6),EMN1(6),EMN2(6),ETQE(6),
34706      &                EMN1SQ(6),EMN2SQ(6),EMPROT,EMNEUT,EMN,
34707      &                EMPROTSQ,EMNEUTSQ,EMNSQ
34708
34709 * steering flags for qel neutrino scattering modules
34710       COMMON /QNEUTO/ DSIGSU,DSIGMC,NDSIG,NEUTYP,NEUDEC
34711 **sr - removed (not needed)
34712 C     COMMON /CAXIAL/ FA0, AXIAL2
34713 C     COMMON /TAUTAU/Q(4,5),ETL,PXL,PYL,PZL,
34714 C    &        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN
34715 **
34716       REAL*8 POL(4,4),BB2(3)
34717       DIMENSION SS(6)
34718 C     DATA C0 /0.17590D0 /  ! G_F**2 cos(theta_c)**2 M**2 /(8 pi) 10**-38 cm+2
34719       DATA SS /1.D0, -1.D0, 1.D0, -1.D0, 1.D0, -1.D0/
34720 **sr uncommented since common block CAXIAL is now commented
34721       DATA AXIAL2 /1.03D0/  ! to be checked
34722 **
34723
34724       RML=P(4,5)
34725       RMM=0.93960D+00
34726       FM2 = RMM**2
34727       MPI = 0.135D+00
34728       OLDQ2=Q2
34729       FA0=-1.253D+00
34730       CSI = 3.71D+00                      !
34731       GVE = 1.D0/ (1.D0 + Q2/(0.84D+00)**2)**2   ! G_e(q**2)
34732       GVM = (1.D0+CSI)*GVE           ! G_m (q**2)
34733       X = Q2/(EMN*EMN)     ! emn=massa barione
34734       XA = X/4.D0
34735       FV1 = 1.D0/(1.D0+XA)*(GVE+XA*GVM)
34736       FV2 = 1.D0/(1.D0+XA)*(GVM-GVE)
34737       FA = FA0/(1.D0 + Q2/AXIAL2**2)**2
34738       FFA = FA*FA
34739       FFV1 = FV1*FV1
34740       FFV2 = FV2*FV2
34741       FP=2.D0*FA*RMM/(MPI**2 + Q2)
34742       RM = EMLSQ(JTYP)/(EMN*EMN)            ! emlsq(jtyp)
34743       A1 = (4.D0+X)*FFA-(4.D0-X)*FFV1+X*FFV2*(1.D0-XA)+4.D0*X*FV1*FV2
34744       A2 = -RM * ((FV1 + FV2)**2 +  FFA)
34745       AA = (XA+0.25D+00*RM)*(A1 + A2)
34746       BB = -X*FA*(FV1 + FV2)
34747       CC = 0.25D+00*(FFA + FFV1 + XA*FFV2)
34748       SU = (4.D+00*ENU*EMN - Q2 - EMLSQ(JTYP))/(EMN*EMN)
34749
34750       OMEGA1=FFA+XA*(FFA+(FV1+FV2)**2   )  ! articolo di ll...-smith
34751       OMEGA2=4.D+00*CC
34752       OMEGA3=2.D+00*FA*(FV1+FV2)
34753       OMEGA4P=(-(FV1+FV2)**2-(FA+2*FP)**2+(4.0D+00+
34754      1     (Q2/FM2))*FP**2)
34755       OMEGA5=OMEGA2
34756       OMEGA4=(OMEGA4P-OMEGA2+2*OMEGA5)/4.D+00
34757       WW1=2.D+00*OMEGA1*EMN**2
34758       WW2=2.D+00*OMEGA2*EMN**2
34759       WW3=2.D+00*OMEGA3*EMN**2
34760       WW4=2.D+00*OMEGA4*EMN**2
34761       WW5=2.D+00*OMEGA5*EMN**2
34762
34763       DO I=1,3
34764         BB2(I)=-P(4,I)/P(4,4)
34765       END DO
34766 c      WRITE(*,*)
34767 c      WRITE(*,*)
34768 c      WRITE(*,*) 'Prepola: ready to transform to lepton rest frame'
34769       N=5
34770
34771       CALL PYROBO(0,0,0.0D0,0.0D0,BB2(1),BB2(2),BB2(3))
34772
34773 * NOW PARTICLES ARE IN THE SCATTERED LEPTON  REST FRAME
34774 c      WRITE(*,*)
34775 c      WRITE(*,*)
34776 c      WRITE(*,*) 'Prepola: now in lepton rest frame'
34777       EE=ENU
34778       QM2=Q2+RML**2
34779       U=Q2/(2.*RMM)
34780       FRAC=QM2*WW1 + (2.D+00*EE*(EE-U) - 0.5D+00*QM2)*WW2 - SS(JTYP)*
34781      +     (0.5D+00/(RMM**2))*(2.D+00*RMM*EE*Q2 - U*QM2)*WW3 +
34782      +     ((RML**2)/(2.D+00*FM2))*(QM2*WW4-2.D+00*RMM*EE*WW5) !<=FM2 inv di RMM!!
34783
34784       FACTK=2.D+00*WW1 -WW2 -SS(JTYP)*(EE/RMM)*WW3 +((EE-U)/RMM)*WW5
34785      +     - ((RML**2)/FM2)*WW4                        !<=FM2 inv di RMM!!
34786
34787       FACTP=2.D+00*EE/RMM*WW2 - (QM2/(2.D+00*RMM**2))*(SS(JTYP)*WW3+WW5)
34788
34789       DO I=1,3
34790         POL(4,I)=RML*SS(JTYP)*(FACTK*P(1,I)+FACTP*P(2,I))/FRAC
34791         POLARX(I)=POL(4,I)
34792       END DO
34793
34794       PMODUL=0.D0
34795       DO I=1,3
34796         PMODUL=PMODUL+POL(4,I)**2
34797       END DO
34798
34799       IF(JTYP.GT.4.AND.NEUDEC.GT.0) THEN
34800          IF(NEUDEC.EQ.1) THEN
34801             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-2),POLARX(3),
34802      +        ETL,PXL,PYL,PZL,
34803      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34804 c
34805 c     Tau has decayed in muon
34806 c
34807          ENDIF
34808          IF(NEUDEC.EQ.2) THEN
34809             CALL DT_LEPDCYP(EML(JTYP),EML(JTYP-4),POLARX(3),
34810      +        ETL,PXL,PYL,PZL,
34811      +        ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34812 c
34813 c     Tau has decayed in electron
34814 c
34815          ENDIF
34816          K(4,1)=15
34817          K(4,4) = 6
34818          K(4,5) = 8
34819          N=N+3
34820 c
34821 c     fill common for muon(electron)
34822 c
34823          P(6,1)=PXL
34824          P(6,2)=PYL
34825          P(6,3)=PZL
34826          P(6,4)=ETL
34827          K(6,1)=1
34828          IF(JTYP.EQ.5) THEN
34829             IF(NEUDEC.EQ.1) THEN
34830                P(6,5)=EML(JTYP-2)
34831                K(6,2)=13
34832             ELSEIF(NEUDEC.EQ.2) THEN
34833                P(6,5)=EML(JTYP-4)
34834                K(6,2)=11
34835             ENDIF
34836          ELSEIF(JTYP.EQ.6) THEN
34837             IF(NEUDEC.EQ.1) THEN
34838                K(6,2)=-13
34839             ELSEIF(NEUDEC.EQ.2) THEN
34840                K(6,2)=-11
34841             ENDIF
34842          END IF
34843          K(6,3)=4
34844          K(6,4)=0
34845          K(6,5)=0
34846 c
34847 c     fill common for tau_(anti)neutrino
34848 c
34849          P(7,1)=PXB
34850          P(7,2)=PYB
34851          P(7,3)=PZB
34852          P(7,4)=ETB
34853          P(7,5)=0.
34854          K(7,1)=1
34855          IF(JTYP.EQ.5) THEN
34856             K(7,2)=16
34857          ELSEIF(JTYP.EQ.6) THEN
34858             K(7,2)=-16
34859          END IF
34860          K(7,3)=4
34861          K(7,4)=0
34862          K(7,5)=0
34863 c
34864 c     Fill common for muon(electron)_(anti)neutrino
34865 c
34866          P(8,1)=PXN
34867          P(8,2)=PYN
34868          P(8,3)=PZN
34869          P(8,4)=ETN
34870          P(8,5)=0.
34871          K(8,1)=1
34872          IF(JTYP.EQ.5) THEN
34873             IF(NEUDEC.EQ.1) THEN
34874                K(8,2)=-14
34875             ELSEIF(NEUDEC.EQ.2) THEN
34876                K(8,2)=-12
34877             ENDIF
34878          ELSEIF(JTYP.EQ.6) THEN
34879             IF(NEUDEC.EQ.1) THEN
34880                K(8,2)=14
34881             ELSEIF(NEUDEC.EQ.2) THEN
34882                K(8,2)=12
34883             ENDIF
34884          END IF
34885          K(8,3)=4
34886          K(8,4)=0
34887          K(8,5)=0
34888       ENDIF
34889 c      WRITE(*,*)
34890 c      WRITE(*,*)
34891
34892 c      IF(PMODUL.GE.1.D+00) THEN
34893 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34894 c        write(*,*) pmodul
34895 c        DO I=1,3
34896 c          POL(4,I)=POL(4,I)/PMODUL
34897 c          POLARX(I)=POL(4,I)
34898 c        END DO
34899 c        PMODUL=0.
34900 c        DO I=1,3
34901 c          PMODUL=PMODUL+POL(4,I)**2
34902 c        END DO
34903 c        WRITE(*,*) 'Pol',(POLARX(I),I=1,3)
34904 c
34905 c      ENDIF
34906
34907 c      WRITE(*,*) 'PMODUL = ',PMODUL
34908
34909 c      WRITE(*,*)
34910 c      WRITE(*,*)
34911 c      WRITE(*,*) 'prepola: Now back to nucl rest frame'
34912
34913       CALL PYROBO(1,5,0.0D0,0.0D0,-BB2(1),-BB2(2),-BB2(3))
34914
34915       XDC = V(4,1)+V(4,5)*P(4,1)/P(4,5)
34916       YDC = V(4,2)+V(4,5)*P(4,2)/P(4,5)
34917       ZDC = V(4,3)+V(4,5)*P(4,3)/P(4,5)
34918       DO NDC =6,8
34919          V(NDC,1) = XDC
34920          V(NDC,2) = YDC
34921          V(NDC,3) = ZDC
34922       END DO
34923
34924       RETURN
34925       END
34926
34927 *$ CREATE DT_TESTROT.FOR
34928 *COPY DT_TESTROT
34929 *
34930 *===testrot============================================================*
34931 *
34932       SUBROUTINE DT_TESTROT(PI,PO,PHI,MODE)
34933
34934       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
34935       SAVE
34936
34937       DIMENSION ROT(3,3),PI(3),PO(3)
34938
34939       IF (MODE.EQ.1) THEN
34940          ROT(1,1) = 1.D0
34941          ROT(1,2) = 0.D0
34942          ROT(1,3) = 0.D0
34943          ROT(2,1) = 0.D0
34944          ROT(2,2) = COS(PHI)
34945          ROT(2,3) = -SIN(PHI)
34946          ROT(3,1) = 0.D0
34947          ROT(3,2) = SIN(PHI)
34948          ROT(3,3) = COS(PHI)
34949       ELSEIF (MODE.EQ.2) THEN
34950          ROT(1,1) = 0.D0
34951          ROT(1,2) = 1.D0
34952          ROT(1,3) = 0.D0
34953          ROT(2,1) = COS(PHI)
34954          ROT(2,2) = 0.D0
34955          ROT(2,3) = -SIN(PHI)
34956          ROT(3,1) = SIN(PHI)
34957          ROT(3,2) = 0.D0
34958          ROT(3,3) = COS(PHI)
34959       ELSEIF (MODE.EQ.3) THEN
34960          ROT(1,1) = 0.D0
34961          ROT(2,1) = 1.D0
34962          ROT(3,1) = 0.D0
34963          ROT(1,2) = COS(PHI)
34964          ROT(2,2) = 0.D0
34965          ROT(3,2) = -SIN(PHI)
34966          ROT(1,3) = SIN(PHI)
34967          ROT(2,3) = 0.D0
34968          ROT(3,3) = COS(PHI)
34969       ELSEIF (MODE.EQ.4) THEN
34970          ROT(1,1) = 1.D0
34971          ROT(2,1) = 0.D0
34972          ROT(3,1) = 0.D0
34973          ROT(1,2) = 0.D0
34974          ROT(2,2) = COS(PHI)
34975          ROT(3,2) = -SIN(PHI)
34976          ROT(1,3) = 0.D0
34977          ROT(2,3) = SIN(PHI)
34978          ROT(3,3) = COS(PHI)
34979       ELSE
34980          STOP ' TESTROT: mode not supported!'
34981       ENDIF
34982       DO 1 J=1,3
34983         PO(J) = ROT(J,1)*PI(1)+ROT(J,2)*PI(2)+ROT(J,3)*PI(3)
34984     1 CONTINUE
34985
34986       RETURN
34987       END
34988
34989 *$ CREATE DT_LEPDCYP.FOR
34990 *COPY DT_LEPDCYP
34991 *
34992 *===lepdcyp============================================================*
34993 *
34994       SUBROUTINE DT_LEPDCYP(AMA,AML,POL,ETL,PXL,PYL,PZL,
34995      &                      ETB,PXB,PYB,PZB,ETN,PXN,PYN,PZN)
34996 C
34997 C-----------------------------------------------------------------
34998 C
34999 C   Author   :- G. Battistoni         10-NOV-1995
35000 C
35001 C=================================================================
35002 C
35003 C   Purpose   : performs decay of polarized lepton in
35004 C               its rest frame: a => b + l + anti-nu
35005 C               (Example: mu- => nu-mu + e- + anti-nu-e)
35006 C               Polarization is assumed along Z-axis
35007 C               WARNING:
35008 C               1) b AND anti-nu ARE ASSUMED TO BE NEUTRINOS
35009 C                  OF NEGLIGIBLE MASS
35010 C               2) RADIATIVE CORRECTIONS ARE NOT CONSIDERED
35011 C                  IN THIS VERSION
35012 C
35013 C   Method    : modifies phase space distribution obtained
35014 C               by routine EXPLOD using a rejection against the
35015 C               matrix element for unpolarized lepton decay
35016 C
35017 C   Inputs    : Mass of a :  AMA
35018 C               Mass of l :  AML
35019 C               Polar. of a: POL
35020 C               (Example: fully polar. mu- decay: AMA=AMMUON, AML=AMELCT,
35021 C                                                 POL = -1)
35022 C
35023 C   Outputs   : kinematic variables in the rest frame of decaying lepton
35024 C               ETL,PXL,PYL,PZL 4-moment of l
35025 C               ETB,PXB,PYB,PZB 4-moment of b
35026 C               ETN,PXN,PYN,PZN 4-moment of anti-nu
35027 C
35028 C============================================================
35029 C +
35030 C Declarations.
35031 C -
35032       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35033       SAVE
35034
35035       PARAMETER ( LINP = 10 ,
35036      &            LOUT = 6 ,
35037      &            LDAT = 9 )
35038
35039       PARAMETER ( KALGNM = 2 )
35040       PARAMETER ( ANGLGB = 5.0D-16 )
35041       PARAMETER ( ANGLSQ = 2.5D-31 )
35042       PARAMETER ( AXCSSV = 0.2D+16 )
35043       PARAMETER ( ANDRFL = 1.0D-38 )
35044       PARAMETER ( AVRFLW = 1.0D+38 )
35045       PARAMETER ( AINFNT = 1.0D+30 )
35046       PARAMETER ( AZRZRZ = 1.0D-30 )
35047       PARAMETER ( EINFNT = +69.07755278982137 D+00 )
35048       PARAMETER ( EZRZRZ = -69.07755278982137 D+00 )
35049       PARAMETER ( ONEMNS = 0.999999999999999  D+00 )
35050       PARAMETER ( ONEPLS = 1.000000000000001  D+00 )
35051       PARAMETER ( CSNNRM = 2.0D-15 )
35052       PARAMETER ( DMXTRN = 1.0D+08 )
35053       PARAMETER ( ZERZER = 0.D+00 )
35054       PARAMETER ( ONEONE = 1.D+00 )
35055       PARAMETER ( TWOTWO = 2.D+00 )
35056       PARAMETER ( THRTHR = 3.D+00 )
35057       PARAMETER ( FOUFOU = 4.D+00 )
35058       PARAMETER ( FIVFIV = 5.D+00 )
35059       PARAMETER ( SIXSIX = 6.D+00 )
35060       PARAMETER ( SEVSEV = 7.D+00 )
35061       PARAMETER ( EIGEIG = 8.D+00 )
35062       PARAMETER ( ANINEN = 9.D+00 )
35063       PARAMETER ( TENTEN = 10.D+00 )
35064       PARAMETER ( HLFHLF = 0.5D+00 )
35065       PARAMETER ( ONETHI = ONEONE / THRTHR )
35066       PARAMETER ( TWOTHI = TWOTWO / THRTHR )
35067       PARAMETER ( PIPIPI = 3.1415926535897932270 D+00 )
35068       PARAMETER ( ENEPER = 2.7182818284590452354 D+00 )
35069       PARAMETER ( SQRENT = 1.6487212707001281468 D+00 )
35070       PARAMETER ( CLIGHT = 2.99792458         D+10 )
35071       PARAMETER ( AVOGAD = 6.0221367          D+23 )
35072       PARAMETER ( AMELGR = 9.1093897          D-28 )
35073       PARAMETER ( PLCKBR = 1.05457266         D-27 )
35074       PARAMETER ( ELCCGS = 4.8032068          D-10 )
35075       PARAMETER ( ELCMKS = 1.60217733         D-19 )
35076       PARAMETER ( AMUGRM = 1.6605402          D-24 )
35077       PARAMETER ( AMMUMU = 0.113428913        D+00 )
35078       PARAMETER ( ALPFSC = 7.2973530791728595 D-03 )
35079       PARAMETER ( FSCTO2 = 5.3251361962113614 D-05 )
35080       PARAMETER ( FSCTO3 = 3.8859399018437826 D-07 )
35081       PARAMETER ( FSCTO4 = 2.8357075508200407 D-09 )
35082       PARAMETER ( PLABRC = 0.197327053        D+00 )
35083       PARAMETER ( AMELCT = 0.51099906         D-03 )
35084       PARAMETER ( AMUGEV = 0.93149432         D+00 )
35085       PARAMETER ( AMMUON = 0.105658389        D+00 )
35086       PARAMETER ( RCLSEL = 2.8179409183694872 D-13 )
35087       PARAMETER ( GEVMEV = 1.0                D+03 )
35088       PARAMETER ( EMVGEV = 1.0                D-03 )
35089       PARAMETER ( ALGVMV = 6.90775527898214   D+00 )
35090       PARAMETER ( RADDEG = 180.D+00 / PIPIPI )
35091       PARAMETER ( DEGRAD = PIPIPI / 180.D+00 )
35092 C +
35093 C    variables for EXPLOD
35094 C -
35095       PARAMETER ( KPMX = 10 )
35096       DIMENSION AMEXPL (KPMX), PXEXPL (KPMX), PYEXPL (KPMX),
35097      &          PZEXPL (KPMX), ETEXPL (KPMX)
35098 C +
35099 C      test variables
35100 C -
35101 **sr - removed (not needed)
35102 C     COMMON /GBATNU/ ELERAT,NTRY
35103 **
35104 C +
35105 C     Initializes test variables
35106 C -
35107       NTRY = 0
35108       ELERAT = 0.D+00
35109 C +
35110 C     Maximum value for matrix element
35111 C -
35112       ELEMAX = ( AMA**2 + AML**2 )**2 / AMA**2 * ( AMA**2 - AML**2 +
35113      &  SQRT( AMA**4 + AML**4 - 3.D+00 * AMA**2 * AML**2 ) )
35114 C + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
35115 C     Inputs for EXPLOD
35116 C part. no. 1 is l       (e- in mu- decay)
35117 C part. no. 2 is b       (nu-mu in mu- decay)
35118 C part. no. 3 is anti-nu (anti-nu-e in mu- decay)
35119 C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
35120       NPEXPL = 3
35121       ETOTEX = AMA
35122       AMEXPL(1) = AML
35123       AMEXPL(2) = 0.D+00
35124       AMEXPL(3) = 0.D+00
35125 C +
35126 C     phase space distribution
35127 C -
35128   100 CONTINUE
35129       NTRY = NTRY + 1
35130
35131       CALL EXPLOD ( NPEXPL, AMEXPL, ETOTEX, ETEXPL, PXEXPL,
35132      &              PYEXPL, PZEXPL )
35133
35134 C +
35135 C  Calculates matrix element:
35136 C  64*GF**2{[P(a)-ama*S(a)]*P(anti-nu)}{P(l)*P(b)}
35137 C  Here CTH is the cosine of the angle between anti-nu and Z axis
35138 C -
35139       CTH = PZEXPL(3) / SQRT ( PXEXPL(3)**2 + PYEXPL(3)**2 +
35140      &  PZEXPL(3)**2 )
35141       PROD1 = ETEXPL(3) * AMA * (1.D+00 - POL * CTH)
35142       PROD2 = ETEXPL(1) * ETEXPL(2) - PXEXPL(1)*PXEXPL(2) -
35143      &     PYEXPL(1)*PYEXPL(2) - PZEXPL(1)*PZEXPL(2)
35144       ELEMAT = 16.D+00 * PROD1 * PROD2
35145       IF(ELEMAT.GT.ELEMAX) THEN
35146         WRITE(LOUT,*) 'Problems in LEPDCY',ELEMAX,ELEMAT
35147         STOP
35148       ENDIF
35149 C +
35150 C     Here performs the rejection
35151 C -
35152       TEST = DT_RNDM(ETOTEX) * ELEMAX
35153       IF ( TEST .GT. ELEMAT ) GO TO 100
35154 C +
35155 C     final assignment of variables
35156 C -
35157       ELERAT = ELEMAT/ELEMAX
35158       ETL = ETEXPL(1)
35159       PXL = PXEXPL(1)
35160       PYL = PYEXPL(1)
35161       PZL = PZEXPL(1)
35162       ETB = ETEXPL(2)
35163       PXB = PXEXPL(2)
35164       PYB = PYEXPL(2)
35165       PZB = PZEXPL(2)
35166       ETN = ETEXPL(3)
35167       PXN = PXEXPL(3)
35168       PYN = PYEXPL(3)
35169       PZN = PZEXPL(3)
35170   999 RETURN
35171       END
35172
35173 *$ CREATE DT_GEN_DELTA.FOR
35174 *COPY DT_GEN_DELTA
35175 C==================================================================
35176 C.  Generation of  Delta resonance events
35177 C==================================================================
35178 *
35179 *===gen_delta==========================================================*
35180 *
35181       SUBROUTINE DT_GEN_DELTA(ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25)
35182
35183       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35184       SAVE
35185
35186       PARAMETER ( LINP = 10 ,
35187      &            LOUT = 6 ,
35188      &            LDAT = 9 )
35189
35190 C...Generate a Delta-production neutrino/antineutrino
35191 C.  CC-interaction on a nucleon
35192 C
35193 C.  INPUT  ENU (GeV) = Neutrino Energy
35194 C.         LLEP = neutrino type
35195 C.         LTARG = nucleon target type 1=p, 2=n.
35196 C.         JINT = 1:CC, 2::NC
35197 C.
35198 C.  OUTPUT PPL(4)  4-monentum of final lepton
35199 C----------------------------------------------------
35200       PARAMETER (MAXLND=4000)
35201       COMMON/PYJETS/N,NPAD,K(MAXLND,5),P(MAXLND,5),V(MAXLND,5)
35202
35203 **sr - removed (not needed)
35204 C     COMMON /CBAD/  LBAD, NBAD
35205 **
35206
35207       DIMENSION PI(3),PO(3)
35208 C     REAL*4 AMD0, AMD, AMN(2), AML0(6), AML, AML2, AMDMIN
35209       DIMENSION AML0(6),AMN(2)
35210       DATA AMD0 /1.231/, GAMD /0.12/, DELD/0.169/, AMDMIN/1.084/
35211       DATA AMN  /0.93827231, 0.93956563/
35212       DATA AML0 /2*0.51100E-03,2*0.105659, 2*1.777/
35213
35214 c     WRITE(6,*)' GEN_DEL',ENU,LLEP,LTARG,JINT,P21,P22,P23,P24,P25
35215       LBAD = 0
35216 C...Final lepton mass
35217       IF (JINT.EQ.1) THEN
35218         AML = AML0(LLEP)
35219       ELSE
35220         AML = 0.
35221       ENDIF
35222       AML2 = AML**2
35223
35224 C...Particle labels (LUND)
35225       N = 5
35226       K(1,1) = 21
35227       K(2,1) = 21
35228       K(3,1) = 21
35229       K(4,1) = 1
35230       K(3,3) = 1
35231       K(4,3) = 1
35232       IF (LTARG .EQ. 1)  THEN
35233          K(2,2) = 2212
35234       ELSE
35235          K(2,2) = 2112
35236       ENDIF
35237       K0 = (LLEP-1)/2
35238       K1 = LLEP/2
35239       KA = 12 + 2*K0
35240       IS = -1 + 2*LLEP - 4*K1
35241       LNU = 2 - LLEP + 2*K1
35242       K(1,2) = IS*KA
35243       K(5,1) = 1
35244       K(5,3) = 2
35245       IF (JINT .EQ. 1)  THEN                    ! CC interactions
35246          K(3,2) = IS*24
35247          K(4,2) = IS*(KA-1)
35248         IF(LNU.EQ.1) THEN
35249           IF (LTARG .EQ. 1)  THEN
35250               K(5,2) = 2224
35251           ELSE
35252               K(5,2) = 2214
35253           ENDIF
35254         ELSE
35255           IF (LTARG .EQ. 1)  THEN
35256               K(5,2) = 2114
35257           ELSE
35258               K(5,2) = 1114
35259           ENDIF
35260         ENDIF
35261       ELSE
35262          K(3,2) = 23                           ! NC (Z0) interactions
35263          K(4,2) = K(1,2)
35264 **sr 7.5.00: swop Delta's (bug), Delta+ for proton (LTARG=1),
35265 *                                Delta0 for neutron (LTARG=2)
35266 C        IF (LTARG .EQ. 1)  THEN
35267 C           K(5,2) = 2114
35268 C        ELSE
35269 C           K(5,2) = 2214
35270 C        ENDIF
35271          IF (LTARG .EQ. 1)  THEN
35272             K(5,2) = 2214
35273          ELSE
35274             K(5,2) = 2114
35275          ENDIF
35276 **
35277       ENDIF
35278
35279 C...4-momentum initial lepton
35280       P(1,5) = 0.
35281       P(1,4) = ENU
35282       P(1,1) = 0.
35283       P(1,2) = 0.
35284       P(1,3) = ENU
35285 C...4-momentum initial nucleon
35286       P(2,5) = AMN(LTARG)
35287 C     P(2,4) = P(2,5)
35288 C     P(2,1) = 0.
35289 C     P(2,2) = 0.
35290 C     P(2,3) = 0.
35291        P(2,1) = P21
35292        P(2,2) = P22
35293        P(2,3) = P23
35294        P(2,4) = P24
35295        P(2,5) = P25
35296       N=2
35297       beta1=-p(2,1)/p(2,4)
35298       beta2=-p(2,2)/p(2,4)
35299       beta3=-p(2,3)/p(2,4)
35300       N=2
35301
35302       CALL PYROBO(0,0,0.0D0,0.0D0,BETA1,BETA2,BETA3)
35303
35304 C     print*,' nucl. rest fram ( fermi incl.) prima della rotazione'
35305
35306       phi11=atan(p(1,2)/p(1,3))
35307       pi(1)=p(1,1)
35308       pi(2)=p(1,2)
35309       pi(3)=p(1,3)
35310
35311       CALL DT_TESTROT(PI,Po,PHI11,1)
35312       DO ll=1,3
35313        IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35314       END DO
35315       p(1,1)=po(1)
35316       p(1,2)=po(2)
35317       p(1,3)=po(3)
35318       phi12=atan(p(1,1)/p(1,3))
35319
35320       pi(1)=p(1,1)
35321       pi(2)=p(1,2)
35322       pi(3)=p(1,3)
35323       CALL DT_TESTROT(Pi,Po,PHI12,2)
35324       DO ll=1,3
35325         IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35326       END DO
35327       p(1,1)=po(1)
35328       p(1,2)=po(2)
35329       p(1,3)=po(3)
35330
35331       ENUU=P(1,4)
35332
35333 C...Generate the Mass of the Delta
35334       NTRY = 0
35335 100   R = PYR(0)
35336       AMD=AMD0+0.5*GAMD*TAN((2.*R-1.)*ATAN(2.*DELD/GAMD))
35337       NTRY = NTRY + 1
35338       IF (NTRY .GT. 1000)  THEN
35339          LBAD = 1
35340          WRITE (LOUT,1001)  NBAD, ENUU,AMD,AMDMIN,AMD0,GAMD,ET
35341          RETURN
35342       ENDIF
35343       IF (AMD .LT. AMDMIN)  GOTO 100
35344       ET = ((AMD+AML)**2 - AMN(LTARG)**2)/(2.*AMN(LTARG))
35345       IF (ENUU .LT. ET) GOTO 100
35346
35347 C...Kinematical  limits in Q**2
35348       S = AMN(LTARG)**2 + 2.*AMN(LTARG)*ENUU
35349       SQS = SQRT(S)
35350       PSTAR = (S - AMN(LTARG)**2)/(2.*SQS)
35351       ELF = (S - AMD**2 + AML2)/(2.*SQS)
35352       PLF = SQRT(ELF**2 - AML2)
35353       Q2MIN = -AML2 + 2.*PSTAR*(ELF-PLF)
35354       Q2MAX = -AML2 + 2.*PSTAR*(ELF+PLF)
35355       IF (Q2MIN .LT. 0.)   Q2MIN = 0.
35356
35357       DSIGMAX = DT_DSIGMA_DELTA(LNU,-Q2MIN, S, AML, AMD)
35358 200   Q2 = Q2MIN + (Q2MAX-Q2MIN)*PYR(0)
35359       DSIG = DT_DSIGMA_DELTA(LNU,-Q2, S, AML, AMD)
35360       IF (DSIG .LT.  DSIGMAX*PYR(0)) GOTO 200
35361
35362 C...Generate the kinematics of the final particles
35363       EISTAR = (S + AMN(LTARG)**2)/(2.*SQS)
35364       GAM = EISTAR/AMN(LTARG)
35365       BET = PSTAR/EISTAR
35366       CTSTAR = ELF/PLF - (Q2 + AML2)/(2.*PSTAR*PLF)
35367       EL  = GAM*(ELF + BET*PLF*CTSTAR)
35368       PLZ = GAM*(PLF*CTSTAR + BET*ELF)
35369       PL  = SQRT(EL**2 - AML2)
35370       PLT = SQRT(MAX(1.D-06,(PL*PL - PLZ*PLZ)))
35371       PHI = 6.28319*PYR(0)
35372       P(4,1) = PLT*COS(PHI)
35373       P(4,2) = PLT*SIN(PHI)
35374       P(4,3) = PLZ
35375       P(4,4) = EL
35376       P(4,5) = AML
35377
35378 C...4-momentum of Delta
35379       P(5,1) = -P(4,1)
35380       P(5,2) = -P(4,2)
35381       P(5,3) = ENUU-P(4,3)
35382       P(5,4) = ENUU+AMN(LTARG)-P(4,4)
35383       P(5,5) = AMD
35384
35385 C...4-momentum  of intermediate boson
35386       P(3,5) = -Q2
35387       P(3,4) = P(1,4)-P(4,4)
35388       P(3,1) = P(1,1)-P(4,1)
35389       P(3,2) = P(1,2)-P(4,2)
35390       P(3,3) = P(1,3)-P(4,3)
35391       N=5
35392
35393       DO kw=1,5
35394         pi(1)=p(kw,1)
35395         pi(2)=p(kw,2)
35396         pi(3)=p(kw,3)
35397         CALL DT_TESTROT(Pi,Po,PHI12,3)
35398         DO ll=1,3
35399           IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35400         END DO
35401         p(kw,1)=po(1)
35402         p(kw,2)=po(2)
35403         p(kw,3)=po(3)
35404       END DO
35405
35406 c********************************************
35407
35408         DO kw=1,5
35409           pi(1)=p(kw,1)
35410           pi(2)=p(kw,2)
35411           pi(3)=p(kw,3)
35412           CALL DT_TESTROT(Pi,Po,PHI11,4)
35413           DO ll=1,3
35414             IF(abs(po(ll)).LT.1.D-07) po(ll)=0.
35415           END DO
35416           p(kw,1)=po(1)
35417           p(kw,2)=po(2)
35418           p(kw,3)=po(3)
35419        END DO
35420 c********************************************
35421 C         transform back into Lab.
35422
35423       CALL PYROBO(0,0,0.0D0,0.0D0,-BETA1,-BETA2,-BETA3)
35424
35425 C     WRITE(6,*)' Lab fram ( fermi incl.) '
35426       N=5
35427       CALL PYEXEC
35428
35429       RETURN
35430 1001  FORMAT(2X, 'DT_GEN_DELTA : event rejected ', I5,  6G10.3)
35431       END
35432
35433 *$ CREATE DT_DSIGMA_DELTA.FOR
35434 *COPY DT_DSIGMA_DELTA
35435 *
35436 *===dsigma_delta=======================================================*
35437 *
35438       DOUBLE PRECISION FUNCTION DT_DSIGMA_DELTA (LNU, QQ, S, AML, MD)
35439
35440       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35441       SAVE
35442
35443 C...Reaction nu + N -> lepton + Delta
35444 C.  returns the  cross section
35445 C.  dsigma/dt
35446 C.  INPUT  LNU = 1, 2  (neutrino-antineutrino)
35447 C.         QQ = t (always negative)  GeV**2
35448 C.         S  = (c.m energy)**2      GeV**2
35449 C.  OUTPUT =  10**-38 cm+2/GeV**2
35450 C-----------------------------------------------------
35451       REAL*8 MN, MN2, MN4, MD,MD2, MD4
35452       DATA MN /0.938/
35453       DATA PI /3.1415926/
35454
35455       GF = (1.1664 * 1.97)
35456       GF2 = GF*GF
35457       MN2 = MN*MN
35458       MN4 = MN2*MN2
35459       MD2 = MD*MD
35460       MD4 = MD2*MD2
35461       AML2 = AML*AML
35462       AML4 = AML2*AML2
35463       VQ  = (MN2 - MD2 - QQ)/2.
35464       VPI = (MN2 + MD2 - QQ)/2.
35465       VK  = (S + QQ - MN2 - AML2)/2.
35466       PIK = (S - MN2)/2.
35467       QK = (AML2 - QQ)/2.
35468       PIQ = (QQ + MN2 - MD2)/2.
35469       Q = SQRT(-QQ)
35470       C3V = 2.07*SQRT(EXP(-6.3*Q)*(1.+9*Q))
35471       C3 = SQRT(3.)*C3V/MN
35472       C4 = -C3/MD             ! attenzione al segno
35473       C5A = 1.18/(1.-QQ/0.4225)**2
35474       C32 = C3**2
35475       C42 = C4**2
35476       C5A2 = C5A**2
35477
35478       IF (LNU .EQ. 1)  THEN
35479       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35480      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35481      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35482      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35483       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35484      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35485      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35486      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35487      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35488      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ-
35489      . 4.*MN*C3*C5A*MD2*VK*QQ+4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35490      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35491      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35492      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35493      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK-MD*
35494      . C3*C5A*MD2*PIK*QQ+MD*C3*C5A*MD2*QK*PIQ-3.*MD*C3*C5A
35495      . *VK*VPI*QQ+MD*C3*C5A*VK*VQ*PIQ+3.*MD*C3*C5A*VPI*VQ*
35496      . QK-MD*C3*C5A*VQ**2*PIK+C4*C5A*MD2*VK*VPI*QQ+C4*C5A*
35497      . MD2*VK*VQ*PIQ-C4*C5A*MD2*VPI*VQ*QK-C4*C5A*MD2*VQ**2
35498      . *PIK-C4*C5A*MD4*PIK*QQ+C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35499      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35500      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35501      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35502       ELSE
35503       ANS3=-MD2*VPI*QK*QQ*C32+MD2*VPI*QK*C5A2+2.*MD2*VQ*
35504      . PIK*QK*C32+2.*MD2*VQ*QK*PIQ*C32+MD4*VPI*QK*QQ*C42-
35505      . 2.*VK**2*VPI*QQ*C32+2.*VK**2*VPI*C5A2+4.*VK*VPI*VQ*
35506      . QK*C32+2.*VK*VPI*VQ*C5A2+2.*VPI*VQ**2*QK*C32
35507       ANS2=2.*MN*MD*MD2*VK**2*QQ*C42-4.*MN*MD*MD2*VK*VQ*QK
35508      . *C42-2.*MN*MD*MD2*VQ**2*QK*C42-2.*MN*MD*MD2*QK**2*
35509      . C32-3.*MN*MD*MD2*QK*QQ*C32+MN*MD*MD2*QK*C5A2-MN*MD*
35510      . MD4*QK*QQ*C42+2.*MN*MD*VK**2*C5A2+2.*MN*MD*VK*VQ*
35511      . C5A2+4.*MN*C3*C4*MD2*VK**2*QQ-8.*MN*C3*C4*MD2*VK*VQ
35512      . *QK-4.*MN*C3*C4*MD2*VQ**2*QK-2.*MN*C3*C4*MD4*QK*QQ+
35513      . 4.*MN*C3*C5A*MD2*VK*QQ-4.*MN*C3*C5A*MD2*VQ*QK-2.*MD*
35514      . C3*C4*MD2*VK*PIK*QQ+2.*MD*C3*C4*MD2*VK*QK*PIQ+2.*MD
35515      . *C3*C4*MD2*VPI*QK*QQ+2.*MD*C3*C4*MD2*VQ*PIK*QK+2.*
35516      . MD*C3*C4*MD2*VQ*QK*PIQ-2.*MD*C3*C4*VK**2*VPI*QQ+4.*
35517      . MD*C3*C4*VK*VPI*VQ*QK+2.*MD*C3*C4*VPI*VQ**2*QK+MD*
35518      . C3*C5A*MD2*PIK*QQ-MD*C3*C5A*MD2*QK*PIQ+3.*MD*C3*C5A
35519      . *VK*VPI*QQ-MD*C3*C5A*VK*VQ*PIQ-3.*MD*C3*C5A*VPI*VQ*
35520      . QK+MD*C3*C5A*VQ**2*PIK-C4*C5A*MD2*VK*VPI*QQ-C4*C5A*
35521      . MD2*VK*VQ*PIQ+C4*C5A*MD2*VPI*VQ*QK+C4*C5A*MD2*VQ**2
35522      . *PIK+C4*C5A*MD4*PIK*QQ-C4*C5A*MD4*QK*PIQ-2.*MD2*VK
35523      . **2*VPI*QQ*C42+4.*MD2*VK*VPI*VQ*QK*C42-2.*MD2*VK*
35524      . PIK*QQ*C32+2.*MD2*VK*QK*PIQ*C32+2.*MD2*VPI*VQ**2*QK
35525      . *C42-2.*MD2*VPI*QK**2*C32+ANS3
35526       ENDIF
35527       ANS1=32.*ANS2
35528       ANS=ANS1/(3.*MD2)
35529       P1CM = (S-MN2)/(2.*SQRT(S))
35530       DT_DSIGMA_DELTA  = GF2/2. * ANS/(64.*PI*S*P1CM**2)
35531
35532       RETURN
35533       END
35534
35535 *$ CREATE DT_QGAUS.FOR
35536 *COPY DT_QGAUS
35537 *
35538 *===qgaus==============================================================*
35539 *
35540       SUBROUTINE DT_QGAUS(A,B,SS,ENU,LTYP)
35541
35542       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35543       SAVE
35544
35545       DIMENSION X(5),W(5)
35546       DATA X/.1488743389D0,.4333953941D0,
35547      & .6794095682D0,.8650633666D0,.9739065285D0
35548      */
35549       DATA W/.2955242247D0,.2692667193D0,
35550      & .2190863625D0,.1494513491D0,.0666713443D0
35551      */
35552       XM=0.5D0*(B+A)
35553       XR=0.5D0*(B-A)
35554       SS=0
35555       DO 11 J=1,5
35556         DX=XR*X(J)
35557         SS=SS+W(J)*(DT_DSQEL_Q2(LTYP,ENU,XM+DX)+
35558      &  DT_DSQEL_Q2(LTYP,ENU,XM-DX))
35559 11    CONTINUE
35560       SS=XR*SS
35561
35562       RETURN
35563       END
35564 *$ CREATE DT_DIQBRK.FOR
35565 *COPY DT_DIQBRK
35566 *
35567 *===diqbrk=============================================================*
35568 *
35569       SUBROUTINE DT_DIQBRK
35570
35571       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35572       SAVE
35573
35574 * event history
35575
35576       PARAMETER (NMXHKK=200000)
35577
35578       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35579      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35580      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35581
35582 * extended event history
35583       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35584      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35585      &                IHIST(2,NMXHKK)
35586
35587 * event flag
35588       COMMON /DTEVNO/ NEVENT,ICASCA
35589
35590 C     IF(DT_RNDM(VV).LE.0.5D0)THEN
35591 C       CALL GSQBS1(NHKK)
35592 C       CALL GSQBS2(NHKK)
35593 C       CALL USQBS1(NHKK)
35594 C       CALL USQBS2(NHKK)
35595 C       CALL GSABS1(NHKK)
35596 C       CALL GSABS2(NHKK)
35597 C       CALL USABS1(NHKK)
35598 C       CALL USABS2(NHKK)
35599 C     ELSE
35600 C       CALL GSQBS2(NHKK)
35601 C       CALL GSQBS1(NHKK)
35602 C       CALL USQBS2(NHKK)
35603 C       CALL USQBS1(NHKK)
35604 C       CALL GSABS2(NHKK)
35605 C       CALL GSABS1(NHKK)
35606 C       CALL USABS2(NHKK)
35607 C       CALL USABS1(NHKK)
35608 C     ENDIF
35609
35610       IF(DT_RNDM(VV).LE.0.5D0) THEN
35611         CALL DT_DBREAK(1)
35612         CALL DT_DBREAK(2)
35613         CALL DT_DBREAK(3)
35614         CALL DT_DBREAK(4)
35615         CALL DT_DBREAK(5)
35616         CALL DT_DBREAK(6)
35617         CALL DT_DBREAK(7)
35618         CALL DT_DBREAK(8)
35619       ELSE
35620         CALL DT_DBREAK(2)
35621         CALL DT_DBREAK(1)
35622         CALL DT_DBREAK(4)
35623         CALL DT_DBREAK(3)
35624         CALL DT_DBREAK(6)
35625         CALL DT_DBREAK(5)
35626         CALL DT_DBREAK(8)
35627         CALL DT_DBREAK(7)
35628       ENDIF
35629
35630       RETURN
35631       END
35632
35633 *$ CREATE MUSQBS2.FOR
35634 *COPY MUSQBS2
35635 C
35636 C
35637 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
35638       SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35639      *              IP1,IP21,IP22,IPP1,IPP2,IPIP,ISQ,IGCOUN)
35640 C
35641 C                  USQBS-2 diagram (split target diquark)
35642 C
35643       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
35644       SAVE
35645
35646       PARAMETER ( LINP = 10 ,
35647      &            LOUT = 6 ,
35648      &            LDAT = 9 )
35649
35650 * event history
35651
35652       PARAMETER (NMXHKK=200000)
35653
35654       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
35655      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
35656      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
35657
35658 * extended event history
35659       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
35660      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
35661      &                IHIST(2,NMXHKK)
35662
35663 * Lorentz-parameters of the current interaction
35664       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
35665      &                UMO,PPCM,EPROJ,PPROJ
35666
35667 * diquark-breaking mechanism
35668       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
35669
35670 C
35671       PARAMETER (NTMHKK= 300)
35672       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35673      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35674      +(4,NTMHKK)
35675 *KEEP,XSEADI.
35676       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
35677      +SSMIMQ,VVMTHR
35678 *KEEP,DPRIN.
35679       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
35680       COMMON /EVFLAG/ NUMEV
35681 C
35682 C                  USQBS-2 diagram (split target diquark)
35683 C
35684 C
35685 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
35686 C     Input chain 2(NC2) sea-antiquark(NC2P)-sea-quark(NC2T)
35687 C
35688 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
35689 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35690 C
35691 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35692 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35693 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35694 C
35695 C
35696 C       Put new chains into COMMON /HKKTMP/
35697 C
35698       IIGLU1=NC1T-NC1P-1
35699       IIGLU2=NC2T-NC2P-1
35700       IGCOUN=0
35701 C     WRITE(LOUT,*)'MUSQBS2: IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
35702       CVQ=1.D0
35703       IREJ=0
35704       IF(IPIP.EQ.2)THEN
35705 C     IF(NUMEV.EQ.-324)THEN
35706 C     WRITE(LOUT,*)' MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
35707 C    *             'IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN)',
35708 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35709 C    *              IP1,IP21,IP22,IPP1,IPP2,IPIP,IGCOUN
35710       ENDIF
35711 C
35712 C
35713 C
35714 C     determine x-values of NC1T diquark
35715       XDIQT=PHKK(4,NC1T)*2.D0/UMO
35716       XVQP=PHKK(4,NC1P)*2.D0/UMO
35717 C
35718 C     determine x-values of sea quark pair
35719 C
35720       IPCO=1
35721       ICOU=0
35722  2234 CONTINUE
35723       ICOU=ICOU+1
35724       IF(ICOU.GE.500)THEN
35725         IREJ=1
35726         IF(ISQ.EQ.3)IREJ=3
35727         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 2234 ICOU. GT.500'
35728         IPCO=0
35729         RETURN
35730       ENDIF
35731       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
35732      * UMO, XDIQT,XVQP
35733       XSQ=0.D0
35734       XSAQ=0.D0
35735 **NEW
35736 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
35737       IF (IPIP.EQ.1) THEN
35738          XQMAX  = XDIQT/2.0D0
35739          XAQMAX = 2.D0*XVQP/3.0D0
35740       ELSE
35741          XQMAX  = 2.D0*XVQP/3.0D0
35742          XAQMAX = XDIQT/2.0D0
35743       ENDIF
35744       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
35745       ISAQ = 6+ISQ
35746 C     write(*,*) 'MUSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
35747 **
35748         IF(IPCO.GE.3)
35749      &     WRITE(LOUT,*)'MUSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35750       IF(IREJ.GE.1)THEN
35751         IF(IPCO.GE.3)
35752      &     WRITE(LOUT,*)'MUSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
35753         IPCO=0
35754         RETURN
35755       ENDIF
35756       IF(IPIP.EQ.1)THEN
35757         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35758       ELSEIF(IPIP.EQ.2)THEN
35759         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
35760       ENDIF
35761       IF(IPCO.GE.3)THEN
35762         WRITE(LOUT,'(A,4E12.4)')' MUSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
35763      &  XDIQT,XVQP,XSQ,XSAQ
35764       ENDIF
35765 C
35766 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
35767 C
35768 C     XSQ=0.D0
35769       IF(IPIP.EQ.1)THEN
35770         XDIQT=XDIQT-XSQ
35771         XVQP =XVQP -XSAQ
35772       ELSEIF(IPIP.EQ.2)THEN
35773         XDIQT=XDIQT-XSAQ
35774         XVQP =XVQP -XSQ
35775       ENDIF
35776       IF(IPCO.GE.3)
35777      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
35778 C
35779 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
35780 C
35781       XVTHRO=CVQ/UMO
35782       IVTHR=0
35783  3466 CONTINUE
35784       IF(IVTHR.EQ.10)THEN
35785         IREJ=1
35786         IF(ISQ.EQ.3)IREJ=3
35787         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 3466 reject IVTHR 10'
35788       IPCO=0
35789         RETURN
35790       ENDIF
35791       IVTHR=IVTHR+1
35792       XVTHR=XVTHRO/(201-IVTHR)
35793       UNOPRV=UNON
35794  380  CONTINUE
35795       IF(XVTHR.GT.0.66D0*XDIQT)THEN
35796         IREJ=1
35797         IF(ISQ.EQ.3)IREJ=3
35798         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS2 Rejection 380 XVTHR  large',
35799      *  XVTHR
35800       IPCO=0
35801         RETURN
35802       ENDIF
35803       IF(DT_RNDM(V).LT.0.5D0)THEN
35804         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35805         XVTQII=XDIQT-XVTQI
35806       ELSE
35807         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
35808         XVTQI=XDIQT-XVTQII
35809       ENDIF
35810       IF(IPCO.GE.3)THEN
35811         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
35812       ENDIF
35813 C
35814 C     Prepare 4 momenta of new chains and chain ends
35815 C
35816 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
35817 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
35818 C    +(4,NTMHKK)
35819 C
35820 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35821 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
35822 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
35823 C
35824 C     SUBROUTINE MUSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
35825 C    *              IP1,IP21,IP22,IPP1,IPP2)
35826 C
35827       IF(IPIP.EQ.1)THEN
35828         XSQ1=XSQ
35829         XSAQ1=XSAQ
35830         ISQ1=ISQ
35831         ISAQ1=ISAQ
35832       ELSEIF(IPIP.EQ.2)THEN
35833         XSQ1=XSAQ
35834         XSAQ1=XSQ
35835         ISQ1=ISAQ
35836         ISAQ1=ISQ
35837       ENDIF
35838       IDHKT(1)   =IPP1
35839       ISTHKT(1)  =951
35840       JMOHKT(1,1)=NC2P
35841       JMOHKT(2,1)=0
35842       JDAHKT(1,1)=3+IIGLU1
35843       JDAHKT(2,1)=0
35844 C     Create chains 3 sea antiquark(NC2P 1)-valence-quark(vq1T 2)
35845       PHKT(1,1)  =PHKK(1,NC2P)
35846       PHKT(2,1)  =PHKK(2,NC2P)
35847       PHKT(3,1)  =PHKK(3,NC2P)
35848       PHKT(4,1)  =PHKK(4,NC2P)
35849 C     PHKT(5,1)  =PHKK(5,NC2P)
35850       XMIST  =(PHKT(4,1)**2-
35851      * PHKT(3,1)**2-PHKT(2,1)**2-
35852      *PHKT(1,1)**2)
35853       IF(XMIST.GT.0.D0)THEN
35854       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
35855      *PHKT(1,1)**2)
35856       ELSE
35857 C     WRITE(LOUT,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
35858       PHKT(5,1)=0.D0
35859       ENDIF
35860       VHKT(1,1)  =VHKK(1,NC2P)
35861       VHKT(2,1)  =VHKK(2,NC2P)
35862       VHKT(3,1)  =VHKK(3,NC2P)
35863       VHKT(4,1)  =VHKK(4,NC2P)
35864       WHKT(1,1)  =WHKK(1,NC2P)
35865       WHKT(2,1)  =WHKK(2,NC2P)
35866       WHKT(3,1)  =WHKK(3,NC2P)
35867       WHKT(4,1)  =WHKK(4,NC2P)
35868 C     Add here IIGLU1 gluons to this chaina
35869       PG1=0.D0
35870       PG2=0.D0
35871       PG3=0.D0
35872       PG4=0.D0
35873       IF(IIGLU1.GE.1)THEN
35874       JJG=NC1P
35875       DO 61 IIG=2,2+IIGLU1-1
35876         KKG=JJG+IIG-1
35877         IDHKT(IIG)   =IDHKK(KKG)
35878         ISTHKT(IIG)  =921
35879         JMOHKT(1,IIG)=KKG
35880         JMOHKT(2,IIG)=0
35881         JDAHKT(1,IIG)=3+IIGLU1
35882         JDAHKT(2,IIG)=0
35883         PHKT(1,IIG)=PHKK(1,KKG)
35884         PG1=PG1+ PHKT(1,IIG)
35885         PHKT(2,IIG)=PHKK(2,KKG)
35886         PG2=PG2+ PHKT(2,IIG)
35887         PHKT(3,IIG)=PHKK(3,KKG)
35888         PG3=PG3+ PHKT(3,IIG)
35889         PHKT(4,IIG)=PHKK(4,KKG)
35890         PG4=PG4+ PHKT(4,IIG)
35891         PHKT(5,IIG)=PHKK(5,KKG)
35892         VHKT(1,IIG)  =VHKK(1,KKG)
35893         VHKT(2,IIG)  =VHKK(2,KKG)
35894         VHKT(3,IIG)  =VHKK(3,KKG)
35895         VHKT(4,IIG)  =VHKK(4,KKG)
35896         WHKT(1,IIG) =WHKK(1,KKG)
35897         WHKT(2,IIG) =WHKK(2,KKG)
35898         WHKT(3,IIG) =WHKK(3,KKG)
35899         WHKT(4,IIG) =WHKK(4,KKG)
35900    61 CONTINUE
35901       ENDIF
35902       IDHKT(2+IIGLU1)   =IP21
35903       ISTHKT(2+IIGLU1)  =952
35904       JMOHKT(1,2+IIGLU1)=NC1T
35905       JMOHKT(2,2+IIGLU1)=0
35906       JDAHKT(1,2+IIGLU1)=3+IIGLU1
35907       JDAHKT(2,2+IIGLU1)=0
35908       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
35909       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
35910       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
35911       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
35912 C     PHKT(5,2)  =PHKK(5,NC1T)
35913       XMIST  =(PHKT(4,2+IIGLU1)**2-
35914      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35915      *PHKT(1,2+IIGLU1)**2)
35916       IF(XMIST.GT.0.D0)THEN
35917       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
35918      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
35919      *PHKT(1,2+IIGLU1)**2)
35920       ELSE
35921 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35922         PHKT(5,5+IIGLU1)=0.D0
35923       ENDIF
35924       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
35925       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
35926       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
35927       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
35928       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
35929       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
35930       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
35931       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
35932       IDHKT(3+IIGLU1)   =88888
35933       ISTHKT(3+IIGLU1)  =95
35934       JMOHKT(1,3+IIGLU1)=1
35935       JMOHKT(2,3+IIGLU1)=2+IIGLU1
35936       JDAHKT(1,3+IIGLU1)=0
35937       JDAHKT(2,3+IIGLU1)=0
35938       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
35939       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
35940       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
35941       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
35942       XMIST
35943      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35944      *            -PHKT(3,3+IIGLU1)**2)
35945       IF(XMIST.GT.0.D0)THEN
35946       PHKT(5,3+IIGLU1)
35947      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
35948      *            -PHKT(3,3+IIGLU1)**2)
35949       ELSE
35950 C      WRITE(LOUT,*)' parton 4 mass square LT.0 ',XMIST
35951         PHKT(5,5+IIGLU1)=0.D0
35952       ENDIF
35953       IF(IPIP.GE.2)THEN
35954 C     IF(NUMEV.EQ.-324)THEN
35955 C     WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
35956 C    * JDAHKT(1,1),
35957 C    *JDAHKT(2,1),(PHKT(III,1),III=1,5)
35958       DO 71 IIG=2,2+IIGLU1-1
35959 C     WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
35960 C    &             JMOHKT(1,IIG),JMOHKT(2,IIG),
35961 C    * JDAHKT(1,IIG),
35962 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
35963    71 CONTINUE
35964 C     WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
35965 C    * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
35966 C    *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
35967 C     WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
35968 C    * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
35969 C    *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
35970       ENDIF
35971       CHAMAL=CHAM1
35972       IF(IPIP.EQ.1)THEN
35973         IF(IPP1.LE.-3.OR.IP21.GE.3)CHAMAL=CHAM3
35974       ELSEIF(IPIP.EQ.2)THEN
35975         IF(IPP1.GE.3.OR.IP21.LE.-3)CHAMAL=CHAM3
35976       ENDIF
35977       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
35978 C       IREJ=1
35979         IPCO=0
35980 C       RETURN
35981 C       WRITE(LOUT,*)' MUSQBS1 jump back from chain 3'
35982         GO TO 3466
35983       ENDIF
35984       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
35985       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
35986       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
35987       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
35988       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
35989       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
35990       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
35991       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
35992       IF(IPIP.EQ.1)THEN
35993         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
35994       ELSEIF(IPIP.EQ.2)THEN
35995         IDHKT(4+IIGLU1)   =ISAQ1
35996       ENDIF
35997       ISTHKT(4+IIGLU1)  =951
35998       JMOHKT(1,4+IIGLU1)=NC1P
35999       JMOHKT(2,4+IIGLU1)=0
36000       JDAHKT(1,4+IIGLU1)=6+IIGLU1
36001       JDAHKT(2,4+IIGLU1)=0
36002 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36003       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36004       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36005       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36006       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36007 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
36008       XMIST  =(PHKT(4,4+IIGLU1)**2-
36009      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36010      *PHKT(1,4+IIGLU1)**2)
36011       IF(XMIST.GT.0.D0)THEN
36012       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
36013      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36014      *PHKT(1,4+IIGLU1)**2)
36015       ELSE
36016 C     WRITE(LOUT,*)'MUSQBS2 parton 4 mass square LT.0 ',XMIST
36017       PHKT(5,4+IIGLU1)=0.D0
36018       ENDIF
36019       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
36020       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
36021       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
36022       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
36023       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
36024       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
36025       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
36026       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
36027       IDHKT(5+IIGLU1)   =IP22
36028       ISTHKT(5+IIGLU1)  =952
36029       JMOHKT(1,5+IIGLU1)=NC1T
36030       JMOHKT(2,5+IIGLU1)=0
36031       JDAHKT(1,5+IIGLU1)=6+IIGLU1
36032       JDAHKT(2,5+IIGLU1)=0
36033       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36034       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36035       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36036       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36037 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
36038       XMIST  =(PHKT(4,5+IIGLU1)**2-
36039      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36040      *PHKT(1,5+IIGLU1)**2)
36041       IF(XMIST.GT.0.D0)THEN
36042       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
36043      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36044      *PHKT(1,5+IIGLU1)**2)
36045       ELSE
36046 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36047         PHKT(5,5+IIGLU1)=0.D0
36048       ENDIF
36049       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
36050       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
36051       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
36052       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
36053       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
36054       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
36055       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
36056       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
36057       IDHKT(6+IIGLU1)   =88888
36058       ISTHKT(6+IIGLU1)  =95
36059       JMOHKT(1,6+IIGLU1)=4+IIGLU1
36060       JMOHKT(2,6+IIGLU1)=5+IIGLU1
36061       JDAHKT(1,6+IIGLU1)=0
36062       JDAHKT(2,6+IIGLU1)=0
36063       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36064       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36065       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36066       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36067       XMIST
36068      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36069      *            -PHKT(3,6+IIGLU1)**2)
36070       IF(XMIST.GT.0.D0)THEN
36071       PHKT(5,6+IIGLU1)
36072      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36073      *            -PHKT(3,6+IIGLU1)**2)
36074       ELSE
36075 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36076         PHKT(5,5+IIGLU1)=0.D0
36077       ENDIF
36078 C     IF(IPIP.GE.2)THEN
36079 C     IF(NUMEV.EQ.-324)THEN
36080 C     WRITE(6,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36081 C    * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36082 C    *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36083 C     WRITE(6,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36084 C    * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36085 C    *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36086 C     WRITE(6,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36087 C    * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36088 C    *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36089 C     ENDIF
36090       CHAMAL=CHAM1
36091       IF(IPIP.EQ.1)THEN
36092         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36093       ELSEIF(IPIP.EQ.2)THEN
36094         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36095       ENDIF
36096       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36097 C       IREJ=1
36098         IPCO=0
36099 C       RETURN
36100 C       WRITE(6,*)' MUSQBS1 jump back from chain 6',
36101 C    *  CHAMAL,PHKT(5,6+IIGLU1)
36102         GO TO 3466
36103       ENDIF
36104       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
36105       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
36106       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
36107       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
36108       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
36109       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
36110       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
36111       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
36112 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
36113       IDHKT(7+IIGLU1)   =IP1
36114       ISTHKT(7+IIGLU1)  =951
36115       JMOHKT(1,7+IIGLU1)=NC1P
36116       JMOHKT(2,7+IIGLU1)=0
36117 **NEW
36118 C     JDAHKT(1,7+IIGLU1)=9+IIGLU1
36119       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36120 **
36121       JDAHKT(2,7+IIGLU1)=0
36122       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36123       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36124       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36125       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36126 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
36127       XMIST  =(PHKT(4,7+IIGLU1)**2-
36128      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36129      *PHKT(1,7+IIGLU1)**2)
36130       IF(XMIST.GT.0.D0)THEN
36131       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
36132      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36133      *PHKT(1,7+IIGLU1)**2)
36134       ELSE
36135 C     WRITE(6,*)'MUSQBS2 parton 7 mass square LT.0 ',XMIST
36136       PHKT(5,7+IIGLU1)=0.D0
36137       ENDIF
36138       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
36139       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
36140       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
36141       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
36142       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
36143       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
36144       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
36145       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
36146 C     Insert here the IIGLU2 gluons
36147       PG1=0.D0
36148       PG2=0.D0
36149       PG3=0.D0
36150       PG4=0.D0
36151       IF(IIGLU2.GE.1)THEN
36152       JJG=NC2P
36153       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36154         KKG=JJG+IIG-7-IIGLU1
36155         IDHKT(IIG)   =IDHKK(KKG)
36156         ISTHKT(IIG)  =921
36157         JMOHKT(1,IIG)=KKG
36158         JMOHKT(2,IIG)=0
36159         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36160         JDAHKT(2,IIG)=0
36161         PHKT(1,IIG)=PHKK(1,KKG)
36162         PG1=PG1+ PHKT(1,IIG)
36163         PHKT(2,IIG)=PHKK(2,KKG)
36164         PG2=PG2+ PHKT(2,IIG)
36165         PHKT(3,IIG)=PHKK(3,KKG)
36166         PG3=PG3+ PHKT(3,IIG)
36167         PHKT(4,IIG)=PHKK(4,KKG)
36168         PG4=PG4+ PHKT(4,IIG)
36169         PHKT(5,IIG)=PHKK(5,KKG)
36170         VHKT(1,IIG)  =VHKK(1,KKG)
36171         VHKT(2,IIG)  =VHKK(2,KKG)
36172         VHKT(3,IIG)  =VHKK(3,KKG)
36173         VHKT(4,IIG)  =VHKK(4,KKG)
36174         WHKT(1,IIG)  =WHKK(1,KKG)
36175         WHKT(2,IIG) =WHKK(2,KKG)
36176         WHKT(3,IIG) =WHKK(3,KKG)
36177         WHKT(4,IIG) =WHKK(4,KKG)
36178    81 CONTINUE
36179       ENDIF
36180       IF(IPIP.EQ.1)THEN
36181         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
36182         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36183         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36184         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36185       ELSEIF(IPIP.EQ.2)THEN
36186         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
36187         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36188         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36189         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36190       ENDIF
36191       ISTHKT(8+IIGLU1+IIGLU2)  =952
36192       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36193       JMOHKT(2,8+IIGLU1+IIGLU2)=0
36194       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36195       JDAHKT(2,8+IIGLU1+IIGLU2)=0
36196       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC2T)+
36197      * PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36198       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC2T)+
36199      * PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36200       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC2T)+
36201      * PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36202       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC2T)+
36203      * PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36204 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36205 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36206       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36207 C       IREJ=1
36208 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36209 C    *  ,PHKT(4,8+IIGLU1+IIGLU2), PHKK(4,NC2T),NC2T
36210         IPCO=0
36211 C       RETURN
36212         GO TO 3466
36213       ENDIF
36214 C     PHKT(5,8)  =PHKK(5,NC2T)
36215       XMIST  =(PHKT(4,8+IIGLU1+IIGLU2)**2-
36216      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36217      *PHKT(1,8+IIGLU1+IIGLU2)**2)
36218       IF(XMIST.GT.0.D0)THEN
36219       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(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       ELSE
36223 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36224         PHKT(5,5+IIGLU1)=0.D0
36225       ENDIF
36226       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
36227       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
36228       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
36229       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
36230       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
36231       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
36232       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
36233       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
36234       IDHKT(9+IIGLU1+IIGLU2)   =88888
36235       ISTHKT(9+IIGLU1+IIGLU2)  =95
36236       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36237       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36238       JDAHKT(1,9+IIGLU1+IIGLU2)=0
36239       JDAHKT(2,9+IIGLU1+IIGLU2)=0
36240 **NEW
36241 C     PHKT(1,9+IIGLU1+IIGLU2)
36242 C    * =PHKT(1,7+IIGLU1+IIGLU2)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36243 C     PHKT(2,9+IIGLU1+IIGLU2)
36244 C    * =PHKT(2,7+IIGLU1+IIGLU2)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36245 C     PHKT(3,9+IIGLU1+IIGLU2)
36246 C    * =PHKT(3,7+IIGLU1+IIGLU2)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36247 C     PHKT(4,9+IIGLU1+IIGLU2)
36248 C    * =PHKT(4,7+IIGLU1+IIGLU2)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36249       PHKT(1,9+IIGLU1+IIGLU2)
36250      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36251       PHKT(2,9+IIGLU1+IIGLU2)
36252      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36253       PHKT(3,9+IIGLU1+IIGLU2)
36254      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36255       PHKT(4,9+IIGLU1+IIGLU2)
36256      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36257 **
36258       XMIST
36259      * =(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36260      * -PHKT(2,9+IIGLU1+IIGLU2)**2
36261      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
36262       IF(XMIST.GT.0.D0)THEN
36263       PHKT(5,9+IIGLU1+IIGLU2)
36264      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
36265      * -PHKT(2,9+IIGLU1+IIGLU2)**2
36266      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
36267       ELSE
36268 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
36269         PHKT(5,5+IIGLU1)=0.D0
36270       ENDIF
36271       IF(IPIP.GE.2)THEN
36272 C     IF(NUMEV.EQ.-324)THEN
36273 C     WRITE(6,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36274 C    * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36275 C    *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36276 C     DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36277 C     WRITE(6,*)IIG,ISTHKT(IIG),IDHKT(IIG),JMOHKT(1,IIG),JMOHKT(2,IIG),
36278 C    * JDAHKT(1,IIG),
36279 C    *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36280 C  91 CONTINUE
36281 C     WRITE(6,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36282 C    * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36283 C    *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36284 C    *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36285 C     WRITE(6,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36286 C    * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36287 C    *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36288 C    *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36289       ENDIF
36290       CHAMAL=CHAB1
36291       IF(IPIP.EQ.1)THEN
36292         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36293       ELSEIF(IPIP.EQ.2)THEN
36294         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36295       ENDIF
36296       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
36297 C       IREJ=1
36298         IPCO=0
36299 C       RETURN
36300 C       WRITE(6,*)' MUSQBS1 jump back from chain 9',
36301 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
36302         GO TO 3466
36303       ENDIF
36304       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
36305       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
36306       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
36307       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
36308       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
36309       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
36310       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
36311       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
36312 C
36313       IPCO=0
36314       IGCOUN=9+IIGLU1+IIGLU2
36315        RETURN
36316        END
36317
36318 *$ CREATE MGSQBS2.FOR
36319 *COPY MGSQBS2
36320 C
36321 C
36322 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
36323       SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36324      *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,ISQ,IGCOUN)
36325 C
36326 C                  GSQBS-2 diagram (split target diquark)
36327 C
36328       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
36329       SAVE
36330
36331       PARAMETER ( LINP = 10 ,
36332      &            LOUT = 6 ,
36333      &            LDAT = 9 )
36334
36335 * event history
36336
36337       PARAMETER (NMXHKK=200000)
36338
36339       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
36340      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
36341      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
36342
36343 * extended event history
36344       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
36345      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
36346      &                IHIST(2,NMXHKK)
36347
36348 * Lorentz-parameters of the current interaction
36349       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
36350      &                UMO,PPCM,EPROJ,PPROJ
36351
36352 * diquark-breaking mechanism
36353       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
36354
36355 C
36356       PARAMETER (NTMHKK= 300)
36357       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36358      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36359      +(4,NTMHKK)
36360
36361 *KEEP,XSEADI.
36362       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
36363      +SSMIMQ,VVMTHR
36364 *KEEP,DPRIN.
36365       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
36366 C
36367 C                  GSQBS-2 diagram (split target diquark)
36368 C
36369 C
36370 C     Input chain 1(NC1) valence-quark(NC1P)-valence-diquark(NC1T)
36371 C     Input chain 2(NC2) valence-diquark(NC2P)-sea-quark(NC2T)
36372 C
36373 C     Create antiquark(aqsP)-quark(qsT) pair, energy from NC1P and NC1T
36374 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36375 C
36376 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36377 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36378 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36379 C
36380 C
36381 C
36382 C       Put new chains into COMMON /HKKTMP/
36383 C
36384       IIGLU1=NC1T-NC1P-1
36385       IIGLU2=NC2T-NC2P-1
36386       IGCOUN=0
36387 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
36388       CVQ=1.D0
36389       IREJ=0
36390 C     IF(IPIP.EQ.2)THEN
36391 C     WRITE(6,*)' MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
36392 C    *             'IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN)',
36393 C    *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36394 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IPIP,IGCOUN
36395 C     ENDIF
36396 C
36397 C
36398 C
36399 C     determine x-values of NC1T diquark
36400       XDIQT=PHKK(4,NC1T)*2.D0/UMO
36401       XVQP=PHKK(4,NC1P)*2.D0/UMO
36402 C
36403 C     determine x-values of sea quark pair
36404 C
36405       IPCO=1
36406       ICOU=0
36407  2234 CONTINUE
36408       ICOU=ICOU+1
36409       IF(ICOU.GE.500)THEN
36410         IREJ=1
36411         IF(ISQ.EQ.3)IREJ=3
36412         IF(IPCO.GE.3)
36413      &     WRITE(LOUT,*)' MGSQBS2 Rejection 2234 ICOU. GT.500'
36414         IPCO=0
36415         RETURN
36416       ENDIF
36417       IF(IPCO.GE.3)
36418      &     WRITE(LOUT,*)'MGSQBS2 call  XSEAPA: UMO,XDIQT,XVQP ',
36419      * UMO, XDIQT,XVQP
36420       XSQ=0.D0
36421       XSAQ=0.D0
36422 **NEW
36423 C     CALL XSEAPA(UMO,XDIQT/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
36424       IF (IPIP.EQ.1) THEN
36425          XQMAX  = XDIQT/2.0D0
36426          XAQMAX = 2.D0*XVQP/3.0D0
36427       ELSE
36428          XQMAX  = 2.D0*XVQP/3.0D0
36429          XAQMAX = XDIQT/2.0D0
36430       ENDIF
36431       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
36432       ISAQ = 6+ISQ
36433 C     write(*,*) 'MGSQBS2: ',ISQ,XSQ,XDIQT,XSAQ,XVQP
36434 **
36435         IF(IPCO.GE.3)
36436      &     WRITE(LOUT,*)'MGSQBS2 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36437       IF(IREJ.GE.1)THEN
36438         IF(IPCO.GE.3)
36439      &     WRITE(LOUT,*)'MGSQBS2 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
36440         IPCO=0
36441         RETURN
36442       ENDIF
36443       IF(IPIP.EQ.1)THEN
36444         IF(XSAQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36445       ELSEIF(IPIP.EQ.2)THEN
36446         IF(XSQ.GE.2.D0*XVQP/3.D0)GO TO 2234
36447       ENDIF
36448       IF(IPCO.GE.3)THEN
36449         WRITE(LOUT,'(A,4E12.4)')' MGSQBS2 XDIQT,XVQP,XSQ,XSAQ ',
36450      &  XDIQT,XVQP,XSQ,XSAQ
36451       ENDIF
36452 C
36453 C     subtract xsq,xsaq from NC1T diquark and NC1P quark
36454 C
36455 C     XSQ=0.D0
36456       IF(IPIP.EQ.1)THEN
36457         XDIQT=XDIQT-XSQ
36458         XVQP =XVQP -XSAQ
36459       ELSEIF(IPIP.EQ.2)THEN
36460         XDIQT=XDIQT-XSAQ
36461         XVQP =XVQP -XSQ
36462       ENDIF
36463       IF(IPCO.GE.3)
36464      &   WRITE(LOUT,*)'XDIQT,XVQP after subtraction',XDIQT,XVQP
36465 C
36466 C     Split remaining valence diquark(NC1T) into quarks vq1T and vq2T
36467 C
36468       XVTHRO=CVQ/UMO
36469       IVTHR=0
36470  3466 CONTINUE
36471       IF(IVTHR.EQ.10)THEN
36472         IREJ=1
36473         IF(ISQ.EQ.3)IREJ=3
36474         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 3466 reject IVTHR 10'
36475         IPCO=0
36476         RETURN
36477       ENDIF
36478       IVTHR=IVTHR+1
36479       XVTHR=XVTHRO/(201-IVTHR)
36480       UNOPRV=UNON
36481  380  CONTINUE
36482       IF(XVTHR.GT.0.66D0*XDIQT)THEN
36483         IREJ=1
36484         IF(ISQ.EQ.3)IREJ=3
36485         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS2 Rejection 380 XVTHR  large',
36486      *  XVTHR
36487         IPCO=0
36488         RETURN
36489       ENDIF
36490       IF(DT_RNDM(V).LT.0.5D0)THEN
36491         XVTQI=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36492         XVTQII=XDIQT-XVTQI
36493       ELSE
36494         XVTQII=DT_SAMPEX(XVTHR,0.66D0*XDIQT)
36495         XVTQI=XDIQT-XVTQII
36496       ENDIF
36497       IF(IPCO.GE.3)THEN
36498         WRITE(LOUT,'(A,2E12.4)')'  MGSQBS2:XVTQI,XVTQII ',XVTQI,XVTQII
36499       ENDIF
36500 C
36501 C     Prepare 4 momenta of new chains and chain ends
36502 C
36503 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
36504 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
36505 C    +(4,NTMHKK)
36506 C
36507 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36508 C                   6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36509 C                   9 valence-quark(NC1P 7)-diquark(NC2T+qsT 8)
36510 C
36511 C     SUBROUTINE MGSQBS2(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
36512 C    *              IP1,IP21,IP22,IPP11,IPP12,IPP2,IGCOUN)
36513 C
36514       IF(IPIP.EQ.1)THEN
36515         XSQ1=XSQ
36516         XSAQ1=XSAQ
36517         ISQ1=ISQ
36518         ISAQ1=ISAQ
36519       ELSEIF(IPIP.EQ.2)THEN
36520         XSQ1=XSAQ
36521         XSAQ1=XSQ
36522         ISQ1=ISAQ
36523         ISAQ1=ISQ
36524       ENDIF
36525       KK11=IP21
36526 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36527       KK21=IPP11
36528       KK22=IPP12
36529       XGIVE=0.D0
36530       IF(IPIP.EQ.1)THEN
36531         IDHKT(4+IIGLU1)   =-(ISAQ1-6)
36532       ELSEIF(IPIP.EQ.2)THEN
36533         IDHKT(4+IIGLU1)   =ISAQ1
36534       ENDIF
36535       ISTHKT(4+IIGLU1)  =961
36536       JMOHKT(1,4+IIGLU1)=NC1P
36537       JMOHKT(2,4+IIGLU1)=0
36538       JDAHKT(1,4+IIGLU1)=6+IIGLU1
36539       JDAHKT(2,4+IIGLU1)=0
36540 C     create chain    6 sea-antiquark(aqsP 4)-valence-quark(vq2T 5)
36541       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XSAQ1/(XVQP+XSAQ1)
36542       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XSAQ1/(XVQP+XSAQ1)
36543       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XSAQ1/(XVQP+XSAQ1)
36544       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XSAQ1/(XVQP+XSAQ1)
36545 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
36546       XXMIST=(PHKT(4,4+IIGLU1)**2-
36547      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
36548      *PHKT(1,4+IIGLU1)**2)
36549       IF(XXMIST.GT.0.D0)THEN
36550         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
36551       ELSE
36552         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36553         XXMIST=ABS(XXMIST)
36554         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
36555       ENDIF
36556       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
36557       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
36558       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
36559       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
36560       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
36561       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
36562       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
36563       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
36564       IDHKT(5+IIGLU1)   =IP22
36565       ISTHKT(5+IIGLU1)  =962
36566       JMOHKT(1,5+IIGLU1)=NC1T
36567       JMOHKT(2,5+IIGLU1)=0
36568       JDAHKT(1,5+IIGLU1)=6+IIGLU1
36569       JDAHKT(2,5+IIGLU1)=0
36570       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XVTQII/(XDIQT+XSQ1)
36571       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XVTQII/(XDIQT+XSQ1)
36572       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XVTQII/(XDIQT+XSQ1)
36573       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XVTQII/(XDIQT+XSQ1)
36574 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
36575       XXMIST=(PHKT(4,5+IIGLU1)**2-
36576      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
36577      *PHKT(1,5+IIGLU1)**2)
36578       IF(XXMIST.GT.0.D0)THEN
36579         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
36580       ELSE
36581         WRITE(LOUT,*)' MGSQBS2 XXMIST', XXMIST
36582         XXMIST=ABS(XXMIST)
36583         PHKT(5,5+IIGLU1)  =SQRT(XXMIST)
36584       ENDIF
36585       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
36586       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
36587       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
36588       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
36589       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
36590       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
36591       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
36592       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
36593       IDHKT(6+IIGLU1)   =88888
36594       ISTHKT(6+IIGLU1)  =96
36595       JMOHKT(1,6+IIGLU1)=4+IIGLU1
36596       JMOHKT(2,6+IIGLU1)=5+IIGLU1
36597       JDAHKT(1,6+IIGLU1)=0
36598       JDAHKT(2,6+IIGLU1)=0
36599       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
36600       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
36601       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
36602       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
36603       PHKT(5,6+IIGLU1)
36604      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
36605      *            -PHKT(3,6+IIGLU1)**2)
36606       CHAMAL=CHAM1
36607       IF(IPIP.EQ.1)THEN
36608         IF(IP22.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
36609       ELSEIF(IPIP.EQ.2)THEN
36610         IF(IP22.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
36611       ENDIF
36612 C---------------------------------------------------
36613       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
36614         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
36615 C                    we drop chain 6 and give the energy to chain 3
36616           IDHKT(6+IIGLU1)=22888
36617           XGIVE=1.D0
36618 C         WRITE(6,*)' drop chain 6 xgive=1'
36619           GO TO 7788
36620         ELSEIF(IDHKT(4+IIGLU1).EQ.-IP21)THEN
36621 C                    we drop chain 6 and give the energy to chain 3
36622 C                    and change KK11 to IDHKT(5)
36623           IDHKT(6+IIGLU1)=22888
36624           XGIVE=1.D0
36625 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(5)'
36626           KK11=IDHKT(5+IIGLU1)
36627           GO TO 7788
36628         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP11)THEN
36629 C                    we drop chain 6 and give the energy to chain 3
36630 C                    and change KK21 to IDHKT(5+IIGLU1)
36631 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36632           IDHKT(6+IIGLU1)=22888
36633           XGIVE=1.D0
36634 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(5+IIGLU1)'
36635           KK21=IDHKT(5+IIGLU1)
36636           GO TO 7788
36637         ELSEIF(IDHKT(4+IIGLU1).EQ.-IPP12)THEN
36638 C                    we drop chain 6 and give the energy to chain 3
36639 C                    and change KK22 to IDHKT(5)
36640 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36641           IDHKT(6+IIGLU1)=22888
36642           XGIVE=1.D0
36643 C          WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(5+IIGLU1)'
36644           KK22=IDHKT(5+IIGLU1)
36645           GO TO 7788
36646         ENDIF
36647 C       IREJ=1
36648         IPCO=0
36649 C       RETURN
36650         GO TO 3466
36651       ENDIF
36652  7788 CONTINUE
36653 C---------------------------------------------------
36654       IF(IPIP.GE.3)THEN
36655       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
36656      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
36657      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
36658       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
36659      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
36660      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
36661       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
36662      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
36663      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
36664       ENDIF
36665       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
36666       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
36667       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
36668       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
36669       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
36670       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
36671       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
36672       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
36673 C     IDHKT(1)   =1000*IPP11+100*IPP12+1
36674       IF(IPIP.EQ.1)THEN
36675         IDHKT(1)   =1000*KK21+100*KK22+3
36676         IF(IDHKT(1).EQ.1203)IDHKT(1)=2103
36677         IF(IDHKT(1).EQ.1303)IDHKT(1)=3103
36678         IF(IDHKT(1).EQ.2303)IDHKT(1)=3203
36679       ELSEIF(IPIP.EQ.2)THEN
36680         IDHKT(1)   =1000*KK21+100*KK22-3
36681         IF(IDHKT(1).EQ.-1203)IDHKT(1)=-2103
36682         IF(IDHKT(1).EQ.-1303)IDHKT(1)=-3103
36683         IF(IDHKT(1).EQ.-2303)IDHKT(1)=-3203
36684       ENDIF
36685       ISTHKT(1)  =961
36686       JMOHKT(1,1)=NC2P
36687       JMOHKT(2,1)=0
36688       JDAHKT(1,1)=3+IIGLU1
36689       JDAHKT(2,1)=0
36690 C     Create chains 3 valence-diquark(NC2P 1)-valence-quark(vq1T 2)
36691       PHKT(1,1)  =PHKK(1,NC2P)
36692      *+XGIVE*PHKT(1,4+IIGLU1)
36693       PHKT(2,1)  =PHKK(2,NC2P)
36694      *+XGIVE*PHKT(2,4+IIGLU1)
36695       PHKT(3,1)  =PHKK(3,NC2P)
36696      *+XGIVE*PHKT(3,4+IIGLU1)
36697       PHKT(4,1)  =PHKK(4,NC2P)
36698      *+XGIVE*PHKT(4,4+IIGLU1)
36699 C     PHKT(5,1)  =PHKK(5,NC2P)
36700       XXMIST=PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
36701      *PHKT(1,1)**2
36702       IF(XXMIST.GT.0.D0)THEN
36703         PHKT(5,1)  =SQRT(XXMIST)
36704       ELSE
36705         WRITE(LOUT,*)'MGSQBS2',XXMIST
36706         XXMIST=ABS(XXMIST)
36707         PHKT(5,1)  =SQRT(XXMIST)
36708       ENDIF
36709       VHKT(1,1)  =VHKK(1,NC2P)
36710       VHKT(2,1)  =VHKK(2,NC2P)
36711       VHKT(3,1)  =VHKK(3,NC2P)
36712       VHKT(4,1)  =VHKK(4,NC2P)
36713       WHKT(1,1)  =WHKK(1,NC2P)
36714       WHKT(2,1)  =WHKK(2,NC2P)
36715       WHKT(3,1)  =WHKK(3,NC2P)
36716       WHKT(4,1)  =WHKK(4,NC2P)
36717 C     Add here IIGLU1 gluons to this chaina
36718       PG1=0.D0
36719       PG2=0.D0
36720       PG3=0.D0
36721       PG4=0.D0
36722       IF(IIGLU1.GE.1)THEN
36723       JJG=NC1P
36724       DO 61 IIG=2,2+IIGLU1-1
36725         KKG=JJG+IIG-1
36726         IDHKT(IIG)   =IDHKK(KKG)
36727         ISTHKT(IIG)  =921
36728         JMOHKT(1,IIG)=KKG
36729         JMOHKT(2,IIG)=0
36730         JDAHKT(1,IIG)=3+IIGLU1
36731         JDAHKT(2,IIG)=0
36732         PHKT(1,IIG)=PHKK(1,KKG)
36733         PG1=PG1+ PHKT(1,IIG)
36734         PHKT(2,IIG)=PHKK(2,KKG)
36735         PG2=PG2+ PHKT(2,IIG)
36736         PHKT(3,IIG)=PHKK(3,KKG)
36737         PG3=PG3+ PHKT(3,IIG)
36738         PHKT(4,IIG)=PHKK(4,KKG)
36739         PG4=PG4+ PHKT(4,IIG)
36740         PHKT(5,IIG)=PHKK(5,KKG)
36741         VHKT(1,IIG)  =VHKK(1,KKG)
36742         VHKT(2,IIG)  =VHKK(2,KKG)
36743         VHKT(3,IIG)  =VHKK(3,KKG)
36744         VHKT(4,IIG)  =VHKK(4,KKG)
36745         WHKT(1,IIG)  =WHKK(1,KKG)
36746         WHKT(2,IIG)  =WHKK(2,KKG)
36747         WHKT(3,IIG)  =WHKK(3,KKG)
36748         WHKT(4,IIG)  =WHKK(4,KKG)
36749    61 CONTINUE
36750       ENDIF
36751 C     IDHKT(2)   =IP21
36752       IDHKT(2+IIGLU1)   =KK11
36753       ISTHKT(2+IIGLU1)  =962
36754       JMOHKT(1,2+IIGLU1)=NC1T
36755       JMOHKT(2,2+IIGLU1)=0
36756       JDAHKT(1,2+IIGLU1)=3+IIGLU1
36757       JDAHKT(2,2+IIGLU1)=0
36758       PHKT(1,2+IIGLU1)  =PHKK(1,NC1T)*XVTQI/(XDIQT+XSQ1)
36759 C    * +0.5D0*PHKK(1,NC2T)
36760      *+XGIVE*PHKT(1,5+IIGLU1)
36761       PHKT(2,2+IIGLU1)  =PHKK(2,NC1T)*XVTQI/(XDIQT+XSQ1)
36762 C    *+0.5D0*PHKK(2,NC2T)
36763      *+XGIVE*PHKT(2,5+IIGLU1)
36764       PHKT(3,2+IIGLU1)  =PHKK(3,NC1T)*XVTQI/(XDIQT+XSQ1)
36765 C    *+0.5D0*PHKK(3,NC2T)
36766      *+XGIVE*PHKT(3,5+IIGLU1)
36767       PHKT(4,2+IIGLU1)  =PHKK(4,NC1T)*XVTQI/(XDIQT+XSQ1)
36768 C    *+0.5D0*PHKK(4,NC2T)
36769      *+XGIVE*PHKT(4,5+IIGLU1)
36770 C     PHKT(5,2)  =PHKK(5,NC1T)
36771       XXMIST=(PHKT(4,2+IIGLU1)**2-
36772      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
36773      *PHKT(1,2+IIGLU1)**2)
36774       IF(XXMIST.GT.0.D0)THEN
36775         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
36776       ELSE
36777         WRITE(LOUT,*)'MGSQBS2 XXMIST',XXMIST
36778         XXMIST=ABS(XXMIST)
36779         PHKT(5,2+IIGLU1)  =SQRT(XXMIST)
36780       ENDIF
36781       VHKT(1,2+IIGLU1)  =VHKK(1,NC1T)
36782       VHKT(2,2+IIGLU1)  =VHKK(2,NC1T)
36783       VHKT(3,2+IIGLU1)  =VHKK(3,NC1T)
36784       VHKT(4,2+IIGLU1)  =VHKK(4,NC1T)
36785       WHKT(1,2+IIGLU1)  =WHKK(1,NC1T)
36786       WHKT(2,2+IIGLU1)  =WHKK(2,NC1T)
36787       WHKT(3,2+IIGLU1)  =WHKK(3,NC1T)
36788       WHKT(4,2+IIGLU1)  =WHKK(4,NC1T)
36789       IDHKT(3+IIGLU1)   =88888
36790       ISTHKT(3+IIGLU1)  =96
36791       JMOHKT(1,3+IIGLU1)=1
36792       JMOHKT(2,3+IIGLU1)=2+IIGLU1
36793       JDAHKT(1,3+IIGLU1)=0
36794       JDAHKT(2,3+IIGLU1)=0
36795       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
36796       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
36797       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
36798       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
36799       PHKT(5,3+IIGLU1)
36800      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
36801      *            -PHKT(3,3+IIGLU1)**2)
36802       IF(IPIP.EQ.3)THEN
36803       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
36804      * JDAHKT(1,1),
36805      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
36806       DO 71 IIG=2,2+IIGLU1-1
36807       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36808      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
36809      * JDAHKT(1,IIG),
36810      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36811    71 CONTINUE
36812       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
36813      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
36814      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
36815       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
36816      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
36817      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
36818       ENDIF
36819       CHAMAL=CHAB1
36820       IF(IPIP.EQ.1)THEN
36821         IF(IPP11.GE.3.OR.IPP12.GE.3.OR.IP21.GE.3)CHAMAL=CHAB3
36822       ELSEIF(IPIP.EQ.2)THEN
36823         IF(IPP11.LE.-3.OR.IPP12.LE.-3.OR.IP21.LE.-3)CHAMAL=CHAB3
36824       ENDIF
36825       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
36826 C       IREJ=1
36827         IPCO=0
36828 C       RETURN
36829         GO TO 3466
36830       ENDIF
36831       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
36832       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
36833       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
36834       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
36835       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
36836       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
36837       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
36838       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
36839 C     IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+1
36840       IDHKT(7+IIGLU1)   =IP1
36841       ISTHKT(7+IIGLU1)  =961
36842       JMOHKT(1,7+IIGLU1)=NC1P
36843       JMOHKT(2,7+IIGLU1)=0
36844       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
36845       JDAHKT(2,7+IIGLU1)=0
36846       PHKT(1,7+IIGLU1)  =PHKK(1,NC1P)*XVQP/(XVQP+XSAQ1)
36847       PHKT(2,7+IIGLU1)  =PHKK(2,NC1P)*XVQP/(XVQP+XSAQ1)
36848       PHKT(3,7+IIGLU1)  =PHKK(3,NC1P)*XVQP/(XVQP+XSAQ1)
36849       PHKT(4,7+IIGLU1)  =PHKK(4,NC1P)*XVQP/(XVQP+XSAQ1)
36850 C     PHKT(5,7+IIGLU1)  =PHKK(5,NC1P)
36851       XXMIST=(PHKT(4,7+IIGLU1)**2-
36852      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
36853      *PHKT(1,7+IIGLU1)**2)
36854       IF(XXMIST.GT.0.D0)THEN
36855         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
36856       ELSE
36857         WRITE(LOUT,*)' MGSQBS2, XXMIST',XXMIST
36858         XXMIST=ABS(XXMIST)
36859         PHKT(5,7+IIGLU1)  =SQRT(XXMIST)
36860       ENDIF
36861       VHKT(1,7+IIGLU1)  =VHKK(1,NC1P)
36862       VHKT(2,7+IIGLU1)  =VHKK(2,NC1P)
36863       VHKT(3,7+IIGLU1)  =VHKK(3,NC1P)
36864       VHKT(4,7+IIGLU1)  =VHKK(4,NC1P)
36865       WHKT(1,7+IIGLU1)  =WHKK(1,NC1P)
36866       WHKT(2,7+IIGLU1)  =WHKK(2,NC1P)
36867       WHKT(3,7+IIGLU1)  =WHKK(3,NC1P)
36868       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
36869 C     IDHKT(7)   =1000*IPP1+100*ISQ+1
36870 C     Insert here the IIGLU2 gluons
36871       PG1=0.D0
36872       PG2=0.D0
36873       PG3=0.D0
36874       PG4=0.D0
36875       IF(IIGLU2.GE.1)THEN
36876       JJG=NC2P
36877       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36878         KKG=JJG+IIG-7-IIGLU1
36879         IDHKT(IIG)   =IDHKK(KKG)
36880         ISTHKT(IIG)  =921
36881         JMOHKT(1,IIG)=KKG
36882         JMOHKT(2,IIG)=0
36883         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
36884         JDAHKT(2,IIG)=0
36885         PHKT(1,IIG)=PHKK(1,KKG)
36886         PG1=PG1+ PHKT(1,IIG)
36887         PHKT(2,IIG)=PHKK(2,KKG)
36888         PG2=PG2+ PHKT(2,IIG)
36889         PHKT(3,IIG)=PHKK(3,KKG)
36890         PG3=PG3+ PHKT(3,IIG)
36891         PHKT(4,IIG)=PHKK(4,KKG)
36892         PG4=PG4+ PHKT(4,IIG)
36893         PHKT(5,IIG)=PHKK(5,KKG)
36894         VHKT(1,IIG)  =VHKK(1,KKG)
36895         VHKT(2,IIG)  =VHKK(2,KKG)
36896         VHKT(3,IIG)  =VHKK(3,KKG)
36897         VHKT(4,IIG)  =VHKK(4,KKG)
36898         WHKT(1,IIG)  =WHKK(1,KKG)
36899         WHKT(2,IIG)  =WHKK(2,KKG)
36900         WHKT(3,IIG)  =WHKK(3,KKG)
36901         WHKT(4,IIG)  =WHKK(4,KKG)
36902    81 CONTINUE
36903       ENDIF
36904       IF(IPIP.EQ.1)THEN
36905         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*ISQ1+3
36906         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1203)IDHKT(8+IIGLU1+IIGLU2)=2103
36907         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.1303)IDHKT(8+IIGLU1+IIGLU2)=3103
36908         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.2303)IDHKT(8+IIGLU1+IIGLU2)=3203
36909       ELSEIF(IPIP.EQ.2)THEN
36910 **NEW
36911 C       IDHKT(8)   =1000*IPP2+100*(-ISQ1+6)-3
36912         IDHKT(8+IIGLU1+IIGLU2)   =1000*IPP2+100*(-ISQ1+6)-3
36913 **
36914         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1203)IDHKT(8+IIGLU1+IIGLU2)=-2103
36915         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-1303)IDHKT(8+IIGLU1+IIGLU2)=-3103
36916         IF(IDHKT(8+IIGLU1+IIGLU2).EQ.-2303)IDHKT(8+IIGLU1+IIGLU2)=-3203
36917       ENDIF
36918       ISTHKT(8+IIGLU1+IIGLU2)  =962
36919       JMOHKT(1,8+IIGLU1+IIGLU2)=NC2T
36920       JMOHKT(2,8+IIGLU1+IIGLU2)=0
36921       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
36922       JDAHKT(2,8+IIGLU1+IIGLU2)=0
36923 C     PHKT(1,8)  =0.5D0*PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ/(XDIQT+XSQ)
36924 C     PHKT(2,8)  =0.5D0*PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ/(XDIQT+XSQ)
36925 C     PHKT(3,8)  =0.5D0*PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ/(XDIQT+XSQ)
36926 C     PHKT(4,8)  =0.5D0*PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ/(XDIQT+XSQ)
36927       PHKT(1,8+IIGLU1+IIGLU2)  =
36928      * PHKK(1,NC2T)+PHKK(1,NC1T)*XSQ1/(XDIQT+XSQ1)
36929       PHKT(2,8+IIGLU1+IIGLU2)  =
36930      * PHKK(2,NC2T)+PHKK(2,NC1T)*XSQ1/(XDIQT+XSQ1)
36931       PHKT(3,8+IIGLU1+IIGLU2)  =
36932      * PHKK(3,NC2T)+PHKK(3,NC1T)*XSQ1/(XDIQT+XSQ1)
36933       PHKT(4,8+IIGLU1+IIGLU2)  =
36934      * PHKK(4,NC2T)+PHKK(4,NC1T)*XSQ1/(XDIQT+XSQ1)
36935 C     WRITE(6,*)'PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)',
36936 C    * PHKK(4,NC1T),PHKK(4,NC2T), PHKT(4,7)
36937       IF(PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T))THEN
36938 C       IREJ=1
36939 C       WRITE(6,*)'reject PHKT(4,8+IIGLU1+IIGLU2).GE. PHKK(4,NC1T)'
36940         IPCO=0
36941 C       RETURN
36942         GO TO 3466
36943       ENDIF
36944 C     PHKT(5,8)  =PHKK(5,NC2T)
36945       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(PHKT(4,8+IIGLU1+IIGLU2)**2-
36946      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
36947      *PHKT(1,8+IIGLU1+IIGLU2)**2)
36948       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC2T)
36949       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC2T)
36950       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC2T)
36951       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC2T)
36952       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC2T)
36953       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC2T)
36954       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC2T)
36955       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC2T)
36956       IDHKT(9+IIGLU1+IIGLU2)   =88888
36957       ISTHKT(9+IIGLU1+IIGLU2)  =96
36958       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
36959       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
36960       JDAHKT(1,9+IIGLU1+IIGLU2)=0
36961       JDAHKT(2,9+IIGLU1+IIGLU2)=0
36962       PHKT(1,9+IIGLU1+IIGLU2)
36963      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
36964       PHKT(2,9+IIGLU1+IIGLU2)
36965      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
36966       PHKT(3,9+IIGLU1+IIGLU2)
36967      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
36968       PHKT(4,9+IIGLU1+IIGLU2)
36969      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
36970       PHKT(5,9+IIGLU1+IIGLU2)
36971      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
36972      * PHKT(2,9+IIGLU1+IIGLU2)**2
36973      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
36974       IF(IPIP.GE.3)THEN
36975       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
36976      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
36977      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
36978       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
36979       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
36980      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
36981      * JDAHKT(1,IIG),
36982      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
36983    91 CONTINUE
36984       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
36985      * IDHKT(8+IIGLU1+IIGLU2),JMOHKT(1,8+IIGLU1+IIGLU2),
36986      *JMOHKT(2,8+IIGLU1+IIGLU2),JDAHKT(1,8+IIGLU1+IIGLU2),
36987      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
36988       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
36989      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
36990      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
36991      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
36992       ENDIF
36993       CHAMAL=CHAB1
36994       IF(IPIP.EQ.1)THEN
36995         IF(IP1.GE.3.OR.IPP2.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
36996       ELSEIF(IPIP.EQ.2)THEN
36997         IF(IP1.LE.-3.OR.IPP2.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
36998       ENDIF
36999       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37000 C       IREJ=1
37001         IPCO=0
37002 C       RETURN
37003         GO TO 3466
37004       ENDIF
37005       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
37006       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
37007       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
37008       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
37009       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
37010       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
37011       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
37012       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
37013 C
37014       IPCO=0
37015       IGCOUN=9+IIGLU1+IIGLU2
37016        RETURN
37017        END
37018
37019 *$ CREATE MUSQBS1.FOR
37020 *COPY MUSQBS1
37021 C
37022 C
37023 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37024       SUBROUTINE MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37025      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,ISQ,IGCOUN)
37026 C
37027 C                  USQBS-1 diagram (split projectile diquark)
37028 C
37029       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37030       SAVE
37031
37032       PARAMETER ( LINP = 10 ,
37033      &            LOUT = 6 ,
37034      &            LDAT = 9 )
37035
37036 * event history
37037
37038       PARAMETER (NMXHKK=200000)
37039
37040       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37041      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37042      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37043
37044 * extended event history
37045       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37046      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37047      &                IHIST(2,NMXHKK)
37048
37049 * Lorentz-parameters of the current interaction
37050       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37051      &                UMO,PPCM,EPROJ,PPROJ
37052
37053 * diquark-breaking mechanism
37054       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37055
37056 C
37057       PARAMETER (NTMHKK= 300)
37058       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37059      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37060      +(4,NTMHKK)
37061 *KEEP,XSEADI.
37062       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37063      +SSMIMQ,VVMTHR
37064 *KEEP,DPRIN.
37065       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37066       COMMON /EVFLAG/ NUMEV
37067 C
37068 C                  USQBS-1 diagram (split projectile diquark)
37069 C
37070 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37071 C     Input chain 2(NC2) sea-quark(NC2P)-sea-antiquark(NC2T)
37072 C
37073 C     Create quark(qsP)-antiquark(aqsT) pair, energy from NC1P and NC1T
37074 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37075 C
37076 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37077 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37078 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37079 C
37080 C       Put new chains into COMMON /HKKTMP/
37081 C
37082       IIGLU1=NC1T-NC1P-1
37083       IIGLU2=NC2T-NC2P-1
37084       IGCOUN=0
37085 C     WRITE(6,*)'MUSQBS1: IIGLU1,IIGLU2,IPIP ',IIGLU1,IIGLU2,IPIP
37086       CVQ=1.D0
37087       IREJ=0
37088       IF(IPIP.EQ.3)THEN
37089 C     IF(NUMEV.EQ.-324)THEN
37090       WRITE(LOUT,*)' MUSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37091      *             ' IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN)',
37092      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37093      *              IP11,IP12,IP2,IPP1,IPP2,IPIP,IGCOUN
37094       ENDIF
37095 C
37096 C
37097 C
37098 C     determine x-values of NC1P diquark
37099       XDIQP=PHKK(4,NC1P)*2.D0/UMO
37100       XVQT=PHKK(4,NC1T)*2.D0/UMO
37101 C
37102 C     determine x-values of sea quark pair
37103 C
37104       IPCO=1
37105       ICOU=0
37106  2234 CONTINUE
37107       ICOU=ICOU+1
37108       IF(ICOU.GE.500)THEN
37109         IREJ=1
37110         IF(ISQ.EQ.3)IREJ=3
37111         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 2234 ICOU. GT.100'
37112         IPCO=0
37113         RETURN
37114       ENDIF
37115       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
37116      * UMO, XDIQP,XVQT
37117       XSQ=0.D0
37118       XSAQ=0.D0
37119 **NEW
37120 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37121       IF (IPIP.EQ.1) THEN
37122          XQMAX  = XDIQP/2.0D0
37123          XAQMAX = 2.D0*XVQT/3.0D0
37124       ELSE
37125          XQMAX  = 2.D0*XVQT/3.0D0
37126          XAQMAX = XDIQP/2.0D0
37127       ENDIF
37128       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37129       ISAQ = 6+ISQ
37130 C     write(*,*) 'MUSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37131 **
37132       IF(IPCO.GE.3)WRITE(LOUT,*)'MUSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37133       IF(IREJ.GE.1)THEN
37134         IF(IPCO.GE.3)
37135      &     WRITE(LOUT,*)'MUSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37136         IPCO=0
37137         RETURN
37138       ENDIF
37139       IF(IPIP.EQ.1)THEN
37140         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37141       ELSEIF(IPIP.EQ.2)THEN
37142         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37143       ENDIF
37144       IF(IPCO.GE.3)THEN
37145         WRITE(LOUT,'(A,4E12.4)')' MUSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37146      &  XDIQP,XVQT,XSQ,XSAQ
37147       ENDIF
37148 C
37149 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
37150 C
37151 C     XSQ=0.D0
37152       IF(IPIP.EQ.1)THEN
37153         XDIQP=XDIQP-XSQ
37154         XVQT =XVQT -XSAQ
37155       ELSEIF(IPIP.EQ.2)THEN
37156         XDIQP=XDIQP-XSAQ
37157         XVQT =XVQT -XSQ
37158       ENDIF
37159       IF(IPCO.GE.3)
37160      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37161 C
37162 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37163 C
37164       XVTHRO=CVQ/UMO
37165       IVTHR=0
37166  3466 CONTINUE
37167       IF(IVTHR.EQ.10)THEN
37168         IREJ=1
37169         IF(ISQ.EQ.3)IREJ=3
37170         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 3466 reject IVTHR 10'
37171         IPCO=0
37172         RETURN
37173       ENDIF
37174       IVTHR=IVTHR+1
37175       XVTHR=XVTHRO/(201-IVTHR)
37176       UNOPRV=UNON
37177  380  CONTINUE
37178       IF(XVTHR.GT.0.66D0*XDIQP)THEN
37179         IREJ=1
37180         IF(ISQ.EQ.3)IREJ=3
37181         IF(IPCO.GE.3)WRITE(LOUT,*)' MUSQBS1 Rejection 380 XVTHR  large',
37182      *  XVTHR
37183         IPCO=0
37184         RETURN
37185       ENDIF
37186       IF(DT_RNDM(V).LT.0.5D0)THEN
37187         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37188         XVPQII=XDIQP-XVPQI
37189       ELSE
37190         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37191         XVPQI=XDIQP-XVPQII
37192       ENDIF
37193       IF(IPCO.GE.3)THEN
37194         WRITE(LOUT,'(A,2E12.4)')'  MUSQBS1:XVPQI,XVPQII ',XVPQI,XVPQII
37195       ENDIF
37196 C
37197 C     Prepare 4 momenta of new chains and chain ends
37198 C
37199 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37200 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37201 C    +(4,NTMHKK)
37202 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37203 C                   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37204 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37205       IF(IPIP.EQ.1)THEN
37206         XSQ1=XSQ
37207         XSAQ1=XSAQ
37208         ISQ1=ISQ
37209         ISAQ1=ISAQ
37210       ELSEIF(IPIP.EQ.2)THEN
37211         XSQ1=XSAQ
37212         XSAQ1=XSQ
37213         ISQ1=ISAQ
37214         ISAQ1=ISQ
37215       ENDIF
37216       IDHKT(1)   =IP11
37217       ISTHKT(1)  =931
37218       JMOHKT(1,1)=NC1P
37219       JMOHKT(2,1)=0
37220       JDAHKT(1,1)=3+IIGLU1
37221       JDAHKT(2,1)=0
37222 C     Create chains 3 valence quark(vq1P 1)-sea-antiquark(NC2T 2)
37223       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
37224       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
37225       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
37226       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
37227 C     PHKT(5,1)  =PHKK(5,NC1P)
37228       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37229      *PHKT(1,1)**2)
37230       IF(XMIST.GE.0.D0)THEN
37231       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
37232      *PHKT(1,1)**2)
37233       ELSE
37234 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37235        PHKT(5,1)=0.D0
37236       ENDIF
37237       VHKT(1,1)  =VHKK(1,NC1P)
37238       VHKT(2,1)  =VHKK(2,NC1P)
37239       VHKT(3,1)  =VHKK(3,NC1P)
37240       VHKT(4,1)  =VHKK(4,NC1P)
37241       WHKT(1,1)  =WHKK(1,NC1P)
37242       WHKT(2,1)  =WHKK(2,NC1P)
37243       WHKT(3,1)  =WHKK(3,NC1P)
37244       WHKT(4,1)  =WHKK(4,NC1P)
37245 C     Add here IIGLU1 gluons to this chaina
37246       PG1=0.D0
37247       PG2=0.D0
37248       PG3=0.D0
37249       PG4=0.D0
37250       IF(IIGLU1.GE.1)THEN
37251       JJG=NC1P
37252       DO 61 IIG=2,2+IIGLU1-1
37253         KKG=JJG+IIG-1
37254         IDHKT(IIG)   =IDHKK(KKG)
37255         ISTHKT(IIG)  =921
37256         JMOHKT(1,IIG)=KKG
37257         JMOHKT(2,IIG)=0
37258         JDAHKT(1,IIG)=3+IIGLU1
37259         JDAHKT(2,IIG)=0
37260         PHKT(1,IIG)=PHKK(1,KKG)
37261         PG1=PG1+ PHKT(1,IIG)
37262         PHKT(2,IIG)=PHKK(2,KKG)
37263         PG2=PG2+ PHKT(2,IIG)
37264         PHKT(3,IIG)=PHKK(3,KKG)
37265         PG3=PG3+ PHKT(3,IIG)
37266         PHKT(4,IIG)=PHKK(4,KKG)
37267         PG4=PG4+ PHKT(4,IIG)
37268         PHKT(5,IIG)=PHKK(5,KKG)
37269         VHKT(1,IIG)  =VHKK(1,KKG)
37270         VHKT(2,IIG)  =VHKK(2,KKG)
37271         VHKT(3,IIG)  =VHKK(3,KKG)
37272         VHKT(4,IIG)  =VHKK(4,KKG)
37273         WHKT(1,IIG) =WHKK(1,KKG)
37274         WHKT(2,IIG) =WHKK(2,KKG)
37275         WHKT(3,IIG) =WHKK(3,KKG)
37276         WHKT(4,IIG) =WHKK(4,KKG)
37277    61 CONTINUE
37278       ENDIF
37279       IDHKT(2+IIGLU1)   =IPP2
37280       ISTHKT(2+IIGLU1)  =932
37281       JMOHKT(1,2+IIGLU1)=NC2T
37282       JMOHKT(2,2+IIGLU1)=0
37283       JDAHKT(1,2+IIGLU1)=3+IIGLU1
37284       JDAHKT(2,2+IIGLU1)=0
37285       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
37286       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
37287       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
37288       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
37289 C     PHKT(5,2+IIGLU1)  =PHKK(5,NC2T)
37290       XMIST=(PHKT(4,2+IIGLU1)**2-
37291      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37292      *PHKT(1,2+IIGLU1)**2)
37293       IF(XMIST.GT.0.D0)THEN
37294       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
37295      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
37296      *PHKT(1,2+IIGLU1)**2)
37297       ELSE
37298 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37299         PHKT(5,2+IIGLU1)=0.D0
37300       ENDIF
37301       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
37302       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
37303       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
37304       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
37305       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
37306       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
37307       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
37308       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
37309       IDHKT(3+IIGLU1)   =88888
37310       ISTHKT(3+IIGLU1)  =94
37311       JMOHKT(1,3+IIGLU1)=1
37312       JMOHKT(2,3+IIGLU1)=2+IIGLU1
37313       JDAHKT(1,3+IIGLU1)=0
37314       JDAHKT(2,3+IIGLU1)=0
37315       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
37316       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
37317       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
37318       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
37319       XMIST
37320      * =(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37321      *            -PHKT(3,3+IIGLU1)**2)
37322       IF(XMIST.GE.0.D0)THEN
37323       PHKT(5,3+IIGLU1)
37324      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
37325      *            -PHKT(3,3+IIGLU1)**2)
37326       ELSE
37327 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37328        PHKT(5,1)=0.D0
37329       ENDIF
37330       IF(IPIP.GE.3)THEN
37331 C     IF(NUMEV.EQ.-324)THEN
37332       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),
37333      * JMOHKT(2,1),JDAHKT(1,1),
37334      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
37335       DO 71 IIG=2,2+IIGLU1-1
37336       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37337      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
37338      * JDAHKT(1,IIG),
37339      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37340    71 CONTINUE
37341       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),IDHKT(2+IIGLU1),
37342      * JMOHKT(1,2+IIGLU1),JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
37343      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
37344       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
37345      * JMOHKT(1,3+IIGLU1),JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
37346      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
37347       ENDIF
37348       CHAMAL=CHAM1
37349       IF(IPIP.EQ.1)THEN
37350         IF(IP11.GE.3.OR.IPP2.GE.3)CHAMAL=CHAM3
37351       ELSEIF(IPIP.EQ.2)THEN
37352         IF(IP11.LE.-3.OR.IPP2.LE.-3)CHAMAL=CHAM3
37353       ENDIF
37354       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
37355 C       IREJ=1
37356         IPCO=0
37357 C       RETURN
37358 C       WRITE(6,*)' MUSQBS1 jump back from chain 3'
37359         GO TO 3466
37360       ENDIF
37361       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
37362       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
37363       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
37364       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
37365       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
37366       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
37367       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
37368       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
37369       IDHKT(4+IIGLU1)   =IP12
37370       ISTHKT(4+IIGLU1)  =931
37371       JMOHKT(1,4+IIGLU1)=NC1P
37372       JMOHKT(2,4+IIGLU1)=0
37373       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37374       JDAHKT(2,4+IIGLU1)=0
37375 C   create  chain   6 valence quark(vq2P 4)-sea-quark(aqsT 5)
37376       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37377       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37378       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37379       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37380 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37381       XMIST  =(PHKT(4,4+IIGLU1)**2-
37382      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37383      *PHKT(1,4+IIGLU1)**2)
37384       IF(XMIST.GT.0.D0)THEN
37385       PHKT(5,4+IIGLU1)  =SQRT(PHKT(4,4+IIGLU1)**2-
37386      * PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37387      *PHKT(1,4+IIGLU1)**2)
37388       ELSE
37389 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37390         PHKT(5,4+IIGLU1)=0.D0
37391       ENDIF
37392       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37393       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37394       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37395       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37396       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37397       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37398       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37399       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37400       IF(IPIP.EQ.1)THEN
37401         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
37402       ELSEIF(IPIP.EQ.2)THEN
37403         IDHKT(5+IIGLU1)   =ISAQ1
37404       ENDIF
37405       ISTHKT(5+IIGLU1)  =932
37406       JMOHKT(1,5+IIGLU1)=NC1T
37407       JMOHKT(2,5+IIGLU1)=0
37408       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37409       JDAHKT(2,5+IIGLU1)=0
37410       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37411       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37412       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37413       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37414 C     IF( PHKT(4,5).EQ.0.D0)THEN
37415 C       IREJ=1
37416 CIPCO=0
37417 CRETURN
37418 C     ENDIF
37419 C     PHKT(5,5)  =PHKK(5,NC1T)
37420       XMIST=(PHKT(4,5+IIGLU1)**2-
37421      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37422      *PHKT(1,5+IIGLU1)**2)
37423       IF(XMIST.GT.0.D0)THEN
37424       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
37425      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37426      *PHKT(1,5+IIGLU1)**2)
37427       ELSE
37428 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37429         PHKT(5,5+IIGLU1)=0.D0
37430       ENDIF
37431       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37432       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37433       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37434       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37435       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37436       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37437       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37438       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37439       IDHKT(6+IIGLU1)   =88888
37440       ISTHKT(6+IIGLU1)  =94
37441       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37442       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37443       JDAHKT(1,6+IIGLU1)=0
37444       JDAHKT(2,6+IIGLU1)=0
37445       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37446       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37447       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37448       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37449       XMIST
37450      * =(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37451      *            -PHKT(3,6+IIGLU1)**2)
37452       IF(XMIST.GE.0.D0)THEN
37453       PHKT(5,6+IIGLU1)
37454      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37455      *            -PHKT(3,6+IIGLU1)**2)
37456       ELSE
37457 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37458        PHKT(5,1)=0.D0
37459       ENDIF
37460 C     IF(IPIP.EQ.3)THEN
37461       CHAMAL=CHAM1
37462       IF(IPIP.EQ.1)THEN
37463         IF(IP12.GE.3.OR.ISAQ1.GE.9)CHAMAL=CHAM3
37464       ELSEIF(IPIP.EQ.2)THEN
37465         IF(IP12.LE.-3.OR.ISAQ1.GE.3)CHAMAL=CHAM3
37466       ENDIF
37467       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37468 C       IREJ=1
37469         IPCO=0
37470 C       RETURN
37471 C       WRITE(6,*)' MGSQBS1 jump back from chain 6',
37472 C    &  CHAMAL,PHKT(5,6+IIGLU1)
37473         GO TO 3466
37474       ENDIF
37475       IF(IPIP.GE.3)THEN
37476 C     IF(NUMEV.EQ.-324)THEN
37477       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
37478      * JMOHKT(1,4+IIGLU1),JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
37479      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
37480       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
37481      * JMOHKT(1,5+IIGLU1),JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
37482      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
37483       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
37484      * JMOHKT(1,6+IIGLU1),JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
37485      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
37486       ENDIF
37487       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
37488       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
37489       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
37490       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
37491       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
37492       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
37493       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
37494       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
37495       IF(IPIP.EQ.1)THEN
37496         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ+3
37497         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
37498         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
37499         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
37500       ELSEIF(IPIP.EQ.2)THEN
37501         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
37502         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
37503         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
37504         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
37505 C       WRITE(6,*)'IDHKT(7+IIGLU1),IPP1,ISQ1',IDHKT(7+IIGLU1),IPP1,ISQ1
37506       ENDIF
37507       ISTHKT(7+IIGLU1)  =931
37508       JMOHKT(1,7+IIGLU1)=NC2P
37509       JMOHKT(2,7+IIGLU1)=0
37510       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
37511       JDAHKT(2,7+IIGLU1)=0
37512 C    create chain     9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37513       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
37514       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
37515       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
37516       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
37517 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
37518 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
37519       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
37520 C       IREJ=1
37521 C       WRITE(6,*)'reject PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P)'
37522         IPCO=0
37523 C       RETURN
37524         GO TO 3466
37525       ENDIF
37526 C     PHKT(5,7)  =PHKK(5,NC2P)
37527       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
37528      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
37529      *PHKT(1,7+IIGLU1)**2)
37530       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
37531       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
37532       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
37533       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
37534       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
37535       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
37536       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
37537       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
37538 C     Insert here the IIGLU2 gluons
37539       PG1=0.D0
37540       PG2=0.D0
37541       PG3=0.D0
37542       PG4=0.D0
37543       IF(IIGLU2.GE.1)THEN
37544       JJG=NC2P
37545       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37546         KKG=JJG+IIG-7-IIGLU1
37547         IDHKT(IIG)   =IDHKK(KKG)
37548         ISTHKT(IIG)  =921
37549         JMOHKT(1,IIG)=KKG
37550         JMOHKT(2,IIG)=0
37551         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
37552         JDAHKT(2,IIG)=0
37553         PHKT(1,IIG)=PHKK(1,KKG)
37554         PG1=PG1+ PHKT(1,IIG)
37555         PHKT(2,IIG)=PHKK(2,KKG)
37556         PG2=PG2+ PHKT(2,IIG)
37557         PHKT(3,IIG)=PHKK(3,KKG)
37558         PG3=PG3+ PHKT(3,IIG)
37559         PHKT(4,IIG)=PHKK(4,KKG)
37560         PG4=PG4+ PHKT(4,IIG)
37561         PHKT(5,IIG)=PHKK(5,KKG)
37562         VHKT(1,IIG)  =VHKK(1,KKG)
37563         VHKT(2,IIG)  =VHKK(2,KKG)
37564         VHKT(3,IIG)  =VHKK(3,KKG)
37565         VHKT(4,IIG)  =VHKK(4,KKG)
37566         WHKT(1,IIG)  =WHKK(1,KKG)
37567         WHKT(2,IIG) =WHKK(2,KKG)
37568         WHKT(3,IIG) =WHKK(3,KKG)
37569         WHKT(4,IIG) =WHKK(4,KKG)
37570    81 CONTINUE
37571       ENDIF
37572       IDHKT(8+IIGLU1+IIGLU2)   =IP2
37573       ISTHKT(8+IIGLU1+IIGLU2)  =932
37574       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
37575       JMOHKT(2,8+IIGLU1+IIGLU2)=0
37576       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
37577       JDAHKT(2,8+IIGLU1+IIGLU2)=0
37578       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
37579       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
37580       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
37581       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
37582 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
37583       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
37584      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
37585      *PHKT(1,8+IIGLU1+IIGLU2)**2)
37586       IF(XMIST.GT.0.D0)THEN
37587       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(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       ELSE
37591 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37592         PHKT(5,8+IIGLU1+IIGLU2)=0.D0
37593       ENDIF
37594       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
37595       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
37596       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
37597       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
37598       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
37599       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
37600       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
37601       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
37602       IDHKT(9+IIGLU1+IIGLU2)   =88888
37603       ISTHKT(9+IIGLU1+IIGLU2)  =94
37604       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
37605       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
37606       JDAHKT(1,9+IIGLU1+IIGLU2)=0
37607       JDAHKT(2,9+IIGLU1+IIGLU2)=0
37608       PHKT(1,9+IIGLU1+IIGLU2)
37609      * =PHKT(1,7+IIGLU1)+PHKT(1,8+IIGLU1+IIGLU2)+PG1
37610       PHKT(2,9+IIGLU1+IIGLU2)
37611      * =PHKT(2,7+IIGLU1)+PHKT(2,8+IIGLU1+IIGLU2)+PG2
37612       PHKT(3,9+IIGLU1+IIGLU2)
37613      * =PHKT(3,7+IIGLU1)+PHKT(3,8+IIGLU1+IIGLU2)+PG3
37614       PHKT(4,9+IIGLU1+IIGLU2)
37615      * =PHKT(4,7+IIGLU1)+PHKT(4,8+IIGLU1+IIGLU2)+PG4
37616       XMIST
37617      *=(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37618      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37619      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37620       IF(XMIST.GE.0.D0)THEN
37621       PHKT(5,9+IIGLU1+IIGLU2)
37622      *=SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2
37623      * -PHKT(2,9+IIGLU1+IIGLU2)**2
37624      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
37625       ELSE
37626 C      WRITE(6,*)'MUSQBS1 parton 1 mass square LT.0 ',XMIST
37627        PHKT(5,1)=0.D0
37628       ENDIF
37629       IF(IPIP.GE.3)THEN
37630 C     IF(NUMEV.EQ.-324)THEN
37631       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
37632      * JMOHKT(1,7+IIGLU1),JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
37633      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
37634       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
37635       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
37636      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
37637      * JDAHKT(1,IIG),
37638      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
37639    91 CONTINUE
37640       WRITE(LOUT,*)8+IIGLU1+IIGLU2,
37641      * ISTHKT(8+IIGLU1+IIGLU2),IDHKT(8+IIGLU1+IIGLU2),
37642      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
37643      *JDAHKT(1,8+IIGLU1+IIGLU2),
37644      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
37645       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
37646      * IDHKT(9+IIGLU1+IIGLU2),JMOHKT(1,9+IIGLU1+IIGLU2),
37647      *JMOHKT(2,9+IIGLU1+IIGLU2),JDAHKT(1,9+IIGLU1+IIGLU2),
37648      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
37649       ENDIF
37650       CHAMAL=CHAB1
37651       IF(IPIP.EQ.1)THEN
37652         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
37653       ELSEIF(IPIP.EQ.2)THEN
37654         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
37655       ENDIF
37656       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
37657 C       IREJ=1
37658         IPCO=0
37659 C       RETURN
37660 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
37661 C    *  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
37662         GO TO 3466
37663       ENDIF
37664       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
37665       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
37666       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
37667       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
37668       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
37669       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
37670       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
37671       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
37672 C
37673       IPCO=0
37674       IGCOUN=9+IIGLU1+IIGLU2
37675        RETURN
37676        END
37677
37678 *$ CREATE MGSQBS1.FOR
37679 *COPY MGSQBS1
37680 C
37681 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
37682       SUBROUTINE MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37683      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,ISQ,IGCOUN)
37684 C
37685 C                  GSQBS-1 diagram (split projectile diquark)
37686 C
37687       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
37688       SAVE
37689
37690       PARAMETER ( LINP = 10 ,
37691      &            LOUT = 6 ,
37692      &            LDAT = 9 )
37693
37694 * event history
37695
37696       PARAMETER (NMXHKK=200000)
37697
37698       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
37699      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
37700      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
37701
37702 * extended event history
37703       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
37704      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
37705      &                IHIST(2,NMXHKK)
37706
37707 * Lorentz-parameters of the current interaction
37708       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
37709      &                UMO,PPCM,EPROJ,PPROJ
37710
37711 * diquark-breaking mechanism
37712       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
37713
37714 C
37715       PARAMETER (NTMHKK= 300)
37716       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37717      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37718      +(4,NTMHKK)
37719 *KEEP,XSEADI.
37720       COMMON /XSEADI/ XSEACU,UNON,UNOM,UNOSEA,CVQ,CDQ,CSEA,SSMIMA,
37721      +SSMIMQ,VVMTHR
37722 *KEEP,DPRIN.
37723       COMMON /DPRIN/ IPRI,IPEV,IPPA,IPCO,INIT,IPHKK,ITOPD,IPAUPR
37724 C
37725 C                  GSQBS-1 diagram (split projectile diquark)
37726 C
37727 C
37728 C     Input chain 1(NC1) valence-diquark(NC1P)-valence-quark(NC1T)
37729 C     Input chain 2(NC2) sea-quark(NC2P)-valence-diquark(NC2T)
37730 C
37731 C     Create quark(qs)-antiquark(aqs) pair energy from NC1P and NC1T
37732 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37733 C
37734 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37735 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37736 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37737 C
37738 C       Put new chains into COMMON /HKKTMP/
37739 C
37740       IIGLU1=NC1T-NC1P-1
37741       IIGLU2=NC2T-NC2P-1
37742       IGCOUN=0
37743 C     WRITE(6,*)' IIGLU1,IIGLU2 ',IIGLU1,IIGLU2
37744       CVQ=1.D0
37745       NNNC1=IDHKK(NC1)/1000
37746       MMMC1=IDHKK(NC1)-NNNC1*1000
37747       KKKC1=ISTHKK(NC1)
37748       NNNC2=IDHKK(NC2)/1000
37749       MMMC2=IDHKK(NC2)-NNNC2*1000
37750       KKKC2=ISTHKK(NC2)
37751       IREJ=0
37752       IF(IPIP.EQ.3)THEN
37753       WRITE(LOUT,*)' MGSQBS1(NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,',
37754      *             ' IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN)',
37755      *NC1,NC1P,NC1T,NC2,NC2P,NC2T,IREJ,
37756      *              IP11,IP12,IP2,IPP1,IPP21,IPP22,IPIP,IGCOUN
37757       ENDIF
37758 C
37759 C
37760 C
37761 C     determine x-values of NC1P diquark
37762       XDIQP=PHKK(4,NC1P)*2.D0/UMO
37763       XVQT=PHKK(4,NC1T)*2.D0/UMO
37764 C
37765 C     determine x-values of sea quark pair
37766 C
37767       IPCO=1
37768       ICOU=0
37769  2234 CONTINUE
37770       ICOU=ICOU+1
37771       IF(ICOU.GE.500)THEN
37772         IREJ=1
37773         IF(ISQ.EQ.3)IREJ=3
37774         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 Rejection 2234 ICOU. GT.100'
37775       IPCO=0
37776         RETURN
37777       ENDIF
37778       IF(IPCO.GE.3)WRITE(LOUT,*)'MGSQBS1 call  XSEAPA: UMO,XDIQP,XVQT ',
37779      * UMO, XDIQP,XVQT
37780       XSQ=0.D0
37781       XSAQ=0.D0
37782 **NEW
37783 C     CALL XSEAPA(UMO,XDIQP/2.D0,ISQ,ISAQ,XSQ,XSAQ,IREJ)
37784       IF (IPIP.EQ.1) THEN
37785          XQMAX  = XDIQP/2.0D0
37786          XAQMAX = 2.D0*XVQT/3.0D0
37787       ELSE
37788          XQMAX  = 2.D0*XVQT/3.0D0
37789          XAQMAX = XDIQP/2.0D0
37790       ENDIF
37791       CALL DT_CQPAIR(XQMAX,XAQMAX,XSQ,XSAQ,ISQ,IREJ)
37792       ISAQ = 6+ISQ
37793 C     write(*,*) 'MGSQBS1: ',ISQ,XSQ,XDIQP,XSAQ,XVQT
37794 **
37795         IF(IPCO.GE.3)
37796      &     WRITE(LOUT,*)'MGSQBS1 after XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37797       IF(IREJ.GE.1)THEN
37798         IF(IPCO.GE.3)
37799      &     WRITE(LOUT,*)'MGSQBS1 reject XSEAPA',ISQ,ISAQ,XSQ,XSAQ
37800       IPCO=0
37801         RETURN
37802       ENDIF
37803       IF(IPIP.EQ.1)THEN
37804         IF(XSAQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37805       ELSEIF(IPIP.EQ.2)THEN
37806         IF(XSQ.GE.2.D0*XVQT/3.D0)GO TO 2234
37807       ENDIF
37808       IF(IPCO.GE.3)THEN
37809         WRITE(LOUT,'(A,4E12.4)')' MGSQBS1 XDIQP,XVQT,XSQ,XSAQ ',
37810      &  XDIQP,XVQT,XSQ,XSAQ
37811       ENDIF
37812 C
37813 C     subtract xsq,xsaq from NC1P diquark and NC1T quark
37814 C
37815 C     XSQ=0.D0
37816       IF(IPIP.EQ.1)THEN
37817         XDIQP=XDIQP-XSQ
37818 **NEW
37819 C       IF (XDIQP.LT.0.0D0) WRITE(*,*) ' mgsqbs1: XDIQP<0!!',XDIQP
37820 **
37821         XVQT =XVQT -XSAQ
37822       ELSEIF(IPIP.EQ.2)THEN
37823         XDIQP=XDIQP-XSAQ
37824         XVQT =XVQT -XSQ
37825       ENDIF
37826       IF(IPCO.GE.3)
37827      &   WRITE(LOUT,*)'XDIQP,XVQT after subtraction',XDIQP,XVQT
37828 C
37829 C     Split remaining valence diquark(NC1P) into quarks vq1P and vq2P
37830 C
37831       XVTHRO=CVQ/UMO
37832       IVTHR=0
37833  3466 CONTINUE
37834       IF(IVTHR.EQ.10)THEN
37835         IREJ=1
37836         IF(ISQ.EQ.3)IREJ=3
37837         IF(IPCO.GE.3)WRITE(LOUT,*)' MGSQBS1 3466 reject IVTHR 10'
37838       IPCO=0
37839         RETURN
37840       ENDIF
37841       IVTHR=IVTHR+1
37842       XVTHR=XVTHRO/(201-IVTHR)
37843       UNOPRV=UNON
37844  380  CONTINUE
37845       IF(XVTHR.GT.0.66D0*XDIQP)THEN
37846         IREJ=1
37847         IF(ISQ.EQ.3)IREJ=3
37848         IF(IPCO.GE.3)
37849      &     WRITE(LOUT,*)' MGSQBS1 Rejection 380 XVTHR  large',
37850      *  XVTHR
37851       IPCO=0
37852         RETURN
37853       ENDIF
37854       IF(DT_RNDM(V).LT.0.5D0)THEN
37855         XVPQI=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37856         XVPQII=XDIQP-XVPQI
37857       ELSE
37858         XVPQII=DT_SAMPEX(XVTHR,0.66D0*XDIQP)
37859         XVPQI=XDIQP-XVPQII
37860       ENDIF
37861       IF(IPCO.GE.3)THEN
37862         WRITE(LOUT,'(A,4E12.4)')'  MGSQBS1:XVTHR,XDIQP,XVPQI,XVPQII ',
37863      &  XVTHR,XDIQP,XVPQI,XVPQII
37864       ENDIF
37865 C
37866 C     Prepare 4 momenta of new chains and chain ends
37867 C
37868 C     COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
37869 C    +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
37870 C    +(4,NTMHKK)
37871 C     Create chains 3 valence quark(vq1P 1)-valence diquark(NC2T 2)
37872 C                   6 valence quark(vq2P 4)-sea-quark(aqsP 5)
37873 C                   9 diquark(qsP+NC2P 7)-valence quark(NC1T 8)
37874       IF(IPIP.EQ.1)THEN
37875         XSQ1=XSQ
37876         XSAQ1=XSAQ
37877         ISQ1=ISQ
37878         ISAQ1=ISAQ
37879       ELSEIF(IPIP.EQ.2)THEN
37880         XSQ1=XSAQ
37881         XSAQ1=XSQ
37882         ISQ1=ISAQ
37883         ISAQ1=ISQ
37884       ENDIF
37885       KK11=IP11
37886 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
37887       KK21= IPP21
37888       KK22= IPP22
37889       XGIVE=0.D0
37890       IDHKT(4+IIGLU1)   =IP12
37891       ISTHKT(4+IIGLU1)  =921
37892       JMOHKT(1,4+IIGLU1)=NC1P
37893       JMOHKT(2,4+IIGLU1)=0
37894       JDAHKT(1,4+IIGLU1)=6+IIGLU1
37895       JDAHKT(2,4+IIGLU1)=0
37896 **NEW
37897       IF ((XDIQP.LT.0.0D0).OR.(XVPQII.LT.0.0D0).OR.
37898      &    (XSQ1.LT.0.0D0)) WRITE(LOUT,*) ' mgsqbs1: ',XDIQP,XVPQII,XSQ1
37899 **
37900       PHKT(1,4+IIGLU1)  =PHKK(1,NC1P)*XVPQII/(XDIQP+XSQ1)
37901       PHKT(2,4+IIGLU1)  =PHKK(2,NC1P)*XVPQII/(XDIQP+XSQ1)
37902       PHKT(3,4+IIGLU1)  =PHKK(3,NC1P)*XVPQII/(XDIQP+XSQ1)
37903       PHKT(4,4+IIGLU1)  =PHKK(4,NC1P)*XVPQII/(XDIQP+XSQ1)
37904 C     PHKT(5,4+IIGLU1)  =PHKK(5,NC1P)
37905       XXMIST=(PHKT(4,4+IIGLU1)**2-
37906      *              PHKT(3,4+IIGLU1)**2-PHKT(2,4+IIGLU1)**2-
37907      *              PHKT(1,4+IIGLU1)**2)
37908       IF(XXMIST.GT.0.D0)THEN
37909         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37910       ELSE
37911         WRITE(LOUT,*)'MGSQBS1 XXMIST',XXMIST
37912         XXMIST=ABS(XXMIST)
37913         PHKT(5,4+IIGLU1)  =SQRT(XXMIST)
37914       ENDIF
37915       VHKT(1,4+IIGLU1)  =VHKK(1,NC1P)
37916       VHKT(2,4+IIGLU1)  =VHKK(2,NC1P)
37917       VHKT(3,4+IIGLU1)  =VHKK(3,NC1P)
37918       VHKT(4,4+IIGLU1)  =VHKK(4,NC1P)
37919       WHKT(1,4+IIGLU1)  =WHKK(1,NC1P)
37920       WHKT(2,4+IIGLU1)  =WHKK(2,NC1P)
37921       WHKT(3,4+IIGLU1)  =WHKK(3,NC1P)
37922       WHKT(4,4+IIGLU1)  =WHKK(4,NC1P)
37923       IF(IPIP.EQ.1)THEN
37924         IDHKT(5+IIGLU1)   =-(ISAQ1-6)
37925       ELSEIF(IPIP.EQ.2)THEN
37926         IDHKT(5+IIGLU1)   =ISAQ1
37927       ENDIF
37928       ISTHKT(5+IIGLU1)  =922
37929       JMOHKT(1,5+IIGLU1)=NC1T
37930       JMOHKT(2,5+IIGLU1)=0
37931       JDAHKT(1,5+IIGLU1)=6+IIGLU1
37932       JDAHKT(2,5+IIGLU1)=0
37933 **NEW
37934       IF ((XSAQ1.LT.0.0D0).OR.(XVQT  .LT.0.0D0))
37935      &    WRITE(LOUT,*) ' mgsqbs2: ',XSAQ1,XVQT
37936 **
37937       PHKT(1,5+IIGLU1)  =PHKK(1,NC1T)*XSAQ1/(XVQT+XSAQ1)
37938       PHKT(2,5+IIGLU1)  =PHKK(2,NC1T)*XSAQ1/(XVQT+XSAQ1)
37939       PHKT(3,5+IIGLU1)  =PHKK(3,NC1T)*XSAQ1/(XVQT+XSAQ1)
37940       PHKT(4,5+IIGLU1)  =PHKK(4,NC1T)*XSAQ1/(XVQT+XSAQ1)
37941 C     PHKT(5,5+IIGLU1)  =PHKK(5,NC1T)
37942       XMIST=(PHKT(4,5+IIGLU1)**2-
37943      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37944      *PHKT(1,5+IIGLU1)**2)
37945       IF(XMIST.GT.0.D0)THEN
37946       PHKT(5,5+IIGLU1)  =SQRT(PHKT(4,5+IIGLU1)**2-
37947      * PHKT(3,5+IIGLU1)**2-PHKT(2,5+IIGLU1)**2-
37948      *PHKT(1,5+IIGLU1)**2)
37949       ELSE
37950 C      WRITE(6,*)' parton 4 mass square LT.0 ',XMIST
37951         PHKT(5,5+IIGLU1)=0.D0
37952       ENDIF
37953       VHKT(1,5+IIGLU1)  =VHKK(1,NC1T)
37954       VHKT(2,5+IIGLU1)  =VHKK(2,NC1T)
37955       VHKT(3,5+IIGLU1)  =VHKK(3,NC1T)
37956       VHKT(4,5+IIGLU1)  =VHKK(4,NC1T)
37957       WHKT(1,5+IIGLU1)  =WHKK(1,NC1T)
37958       WHKT(2,5+IIGLU1)  =WHKK(2,NC1T)
37959       WHKT(3,5+IIGLU1)  =WHKK(3,NC1T)
37960       WHKT(4,5+IIGLU1)  =WHKK(4,NC1T)
37961       IDHKT(6+IIGLU1)   =88888
37962 C     IDHKT(6)   =1000*NNNC1+MMMC1
37963       ISTHKT(6+IIGLU1)  =93
37964 C     ISTHKT(6)  =KKKC1
37965       JMOHKT(1,6+IIGLU1)=4+IIGLU1
37966       JMOHKT(2,6+IIGLU1)=5+IIGLU1
37967       JDAHKT(1,6+IIGLU1)=0
37968       JDAHKT(2,6+IIGLU1)=0
37969       PHKT(1,6+IIGLU1)  =PHKT(1,4+IIGLU1)+PHKT(1,5+IIGLU1)
37970       PHKT(2,6+IIGLU1)  =PHKT(2,4+IIGLU1)+PHKT(2,5+IIGLU1)
37971       PHKT(3,6+IIGLU1)  =PHKT(3,4+IIGLU1)+PHKT(3,5+IIGLU1)
37972       PHKT(4,6+IIGLU1)  =PHKT(4,4+IIGLU1)+PHKT(4,5+IIGLU1)
37973       PHKT(5,6+IIGLU1)
37974      * =SQRT(PHKT(4,6+IIGLU1)**2-PHKT(1,6+IIGLU1)**2-PHKT(2,6+IIGLU1)**2
37975      *            -PHKT(3,6+IIGLU1)**2)
37976       CHAMAL=CHAM1
37977       IF(IPIP.EQ.1)THEN
37978         IF(IP12.GE.3.OR.ISAQ.GE.9)CHAMAL=CHAM3
37979       ELSEIF(IPIP.EQ.2)THEN
37980         IF(IP12.LE.-3.OR.ISAQ.GE.3)CHAMAL=CHAM3
37981       ENDIF
37982       IF(PHKT(5,6+IIGLU1).LT.CHAMAL)THEN
37983         IF(IDHKT(5+IIGLU1).EQ.-IDHKT(4+IIGLU1))THEN
37984 C                    we drop chain 6 and give the energy to chain 3
37985           IDHKT(6+IIGLU1)=33888
37986           XGIVE=1.D0
37987 C         WRITE(6,*)' drop chain 6 xgive=1'
37988           GO TO 7788
37989         ELSEIF(IDHKT(5+IIGLU1).EQ.-IP11)THEN
37990 C                    we drop chain 6 and give the energy to chain 3
37991 C                    and change KK11 to IDHKT(4)
37992           IDHKT(6+IIGLU1)=33888
37993           XGIVE=1.D0
37994 C         WRITE(6,*)' drop chain 6 xgive=1 KK11=IDHKT(4+IIGLU1)'
37995           KK11=IDHKT(4+IIGLU1)
37996           GO TO 7788
37997         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP21)THEN
37998 C                    we drop chain 6 and give the energy to chain 3
37999 C                    and change KK21 to IDHKT(4)
38000 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
38001           IDHKT(6+IIGLU1)=33888
38002           XGIVE=1.D0
38003 C         WRITE(6,*)' drop chain 6 xgive=1 KK21=IDHKT(4+IIGLU1)'
38004           KK21=IDHKT(4+IIGLU1)
38005           GO TO 7788
38006         ELSEIF(IDHKT(5+IIGLU1).EQ.-IPP22)THEN
38007 C                    we drop chain 6 and give the energy to chain 3
38008 C                    and change KK22 to IDHKT(4)
38009 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
38010           IDHKT(6+IIGLU1)=33888
38011           XGIVE=1.D0
38012 C         WRITE(6,*)' drop chain 6 xgive=1 KK22=IDHKT(4+IIGLU1)'
38013           KK22=IDHKT(4+IIGLU1)
38014           GO TO 7788
38015         ENDIF
38016 C       IREJ=1
38017         IPCO=0
38018 C       RETURN
38019 C       WRITE(6,*)' MGSQBS1 jump back from chain 6'
38020         GO TO 3466
38021       ENDIF
38022  7788 CONTINUE
38023       IF(IPIP.GE.3)THEN
38024       WRITE(LOUT,*)4+IIGLU1,ISTHKT(4+IIGLU1),IDHKT(4+IIGLU1),
38025      * JMOHKT(1,4+IIGLU1),
38026      * JMOHKT(2,4+IIGLU1),JDAHKT(1,4+IIGLU1),
38027      *JDAHKT(2,4+IIGLU1),(PHKT(III,4+IIGLU1),III=1,5)
38028       WRITE(LOUT,*)5+IIGLU1,ISTHKT(5+IIGLU1),IDHKT(5+IIGLU1),
38029      * JMOHKT(1,5+IIGLU1),
38030      * JMOHKT(2,5+IIGLU1),JDAHKT(1,5+IIGLU1),
38031      *JDAHKT(2,5+IIGLU1),(PHKT(III,5+IIGLU1),III=1,5)
38032       WRITE(LOUT,*)6+IIGLU1,ISTHKT(6+IIGLU1),IDHKT(6+IIGLU1),
38033      * JMOHKT(1,6+IIGLU1),
38034      * JMOHKT(2,6+IIGLU1),JDAHKT(1,6+IIGLU1),
38035      *JDAHKT(2,6+IIGLU1),(PHKT(III,6+IIGLU1),III=1,5)
38036       ENDIF
38037       VHKT(1,6+IIGLU1)  =VHKK(1,NC1)
38038       VHKT(2,6+IIGLU1)  =VHKK(2,NC1)
38039       VHKT(3,6+IIGLU1)  =VHKK(3,NC1)
38040       VHKT(4,6+IIGLU1)  =VHKK(4,NC1)
38041       WHKT(1,6+IIGLU1)  =WHKK(1,NC1)
38042       WHKT(2,6+IIGLU1)  =WHKK(2,NC1)
38043       WHKT(3,6+IIGLU1)  =WHKK(3,NC1)
38044       WHKT(4,6+IIGLU1)  =WHKK(4,NC1)
38045 C     IDHKT(1)   =IP11
38046       IDHKT(1)   =KK11
38047       ISTHKT(1)  =921
38048       JMOHKT(1,1)=NC1P
38049       JMOHKT(2,1)=0
38050       JDAHKT(1,1)=3+IIGLU1
38051       JDAHKT(2,1)=0
38052       PHKT(1,1)  =PHKK(1,NC1P)*XVPQI/(XDIQP+XSQ1)
38053 C    * +0.5D0*PHKK(1,NC2P)
38054      *+XGIVE*PHKT(1,4+IIGLU1)
38055       PHKT(2,1)  =PHKK(2,NC1P)*XVPQI/(XDIQP+XSQ1)
38056 C    * +0.5D0*PHKK(2,NC2P)
38057      *+XGIVE*PHKT(2,4+IIGLU1)
38058       PHKT(3,1)  =PHKK(3,NC1P)*XVPQI/(XDIQP+XSQ1)
38059 C    * +0.5D0*PHKK(3,NC2P)
38060      *+XGIVE*PHKT(3,4+IIGLU1)
38061       PHKT(4,1)  =PHKK(4,NC1P)*XVPQI/(XDIQP+XSQ1)
38062 C    * +0.5D0*PHKK(4,NC2P)
38063      *+XGIVE*PHKT(4,4+IIGLU1)
38064 C     PHKT(5,1)  =PHKK(5,NC1P)
38065       XMIST  =(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38066      *PHKT(1,1)**2)
38067       IF(XMIST.GE.0.D0)THEN
38068       PHKT(5,1)  =SQRT(PHKT(4,1)**2- PHKT(3,1)**2-PHKT(2,1)**2-
38069      *PHKT(1,1)**2)
38070       ELSE
38071 C      WRITE(6,*)'MGSQBS1 parton 1 mass square LT.0 ',XMIST
38072        PHKT(5,1)=0.D0
38073       ENDIF
38074       VHKT(1,1)  =VHKK(1,NC1P)
38075       VHKT(2,1)  =VHKK(2,NC1P)
38076       VHKT(3,1)  =VHKK(3,NC1P)
38077       VHKT(4,1)  =VHKK(4,NC1P)
38078       WHKT(1,1)  =WHKK(1,NC1P)
38079       WHKT(2,1)  =WHKK(2,NC1P)
38080       WHKT(3,1)  =WHKK(3,NC1P)
38081       WHKT(4,1)  =WHKK(4,NC1P)
38082 C     Add here IIGLU1 gluons to this chaina
38083       PG1=0.D0
38084       PG2=0.D0
38085       PG3=0.D0
38086       PG4=0.D0
38087       IF(IIGLU1.GE.1)THEN
38088       JJG=NC1P
38089       DO 61 IIG=2,2+IIGLU1-1
38090         KKG=JJG+IIG-1
38091         IDHKT(IIG)   =IDHKK(KKG)
38092         ISTHKT(IIG)  =921
38093         JMOHKT(1,IIG)=KKG
38094         JMOHKT(2,IIG)=0
38095         JDAHKT(1,IIG)=3+IIGLU1
38096         JDAHKT(2,IIG)=0
38097         PHKT(1,IIG)=PHKK(1,KKG)
38098         PG1=PG1+ PHKT(1,IIG)
38099         PHKT(2,IIG)=PHKK(2,KKG)
38100         PG2=PG2+ PHKT(2,IIG)
38101         PHKT(3,IIG)=PHKK(3,KKG)
38102         PG3=PG3+ PHKT(3,IIG)
38103         PHKT(4,IIG)=PHKK(4,KKG)
38104         PG4=PG4+ PHKT(4,IIG)
38105         PHKT(5,IIG)=PHKK(5,KKG)
38106         VHKT(1,IIG)  =VHKK(1,KKG)
38107         VHKT(2,IIG)  =VHKK(2,KKG)
38108         VHKT(3,IIG)  =VHKK(3,KKG)
38109         VHKT(4,IIG)  =VHKK(4,KKG)
38110         WHKT(1,IIG)  =WHKK(1,KKG)
38111         WHKT(2,IIG)  =WHKK(2,KKG)
38112         WHKT(3,IIG)  =WHKK(3,KKG)
38113         WHKT(4,IIG)  =WHKK(4,KKG)
38114    61 CONTINUE
38115       ENDIF
38116 C     IDHKT(2)   =1000*IPP21+100*IPP22+1
38117       IF(IPIP.EQ.1)THEN
38118         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22+3
38119         IF(IDHKT(2+IIGLU1).EQ.1203)IDHKT(2+IIGLU1)=2103
38120         IF(IDHKT(2+IIGLU1).EQ.1303)IDHKT(2+IIGLU1)=3103
38121         IF(IDHKT(2+IIGLU1).EQ.2303)IDHKT(2+IIGLU1)=3203
38122       ELSEIF(IPIP.EQ.2)THEN
38123         IDHKT(2+IIGLU1)   =1000*KK21+100*KK22-3
38124         IF(IDHKT(2+IIGLU1).EQ.-1203)IDHKT(2+IIGLU1)=-2103
38125         IF(IDHKT(2+IIGLU1).EQ.-1303)IDHKT(2+IIGLU1)=-3103
38126         IF(IDHKT(2+IIGLU1).EQ.-2303)IDHKT(2+IIGLU1)=-3203
38127       ENDIF
38128       ISTHKT(2+IIGLU1)  =922
38129       JMOHKT(1,2+IIGLU1)=NC2T
38130       JMOHKT(2,2+IIGLU1)=0
38131       JDAHKT(1,2+IIGLU1)=3+IIGLU1
38132       JDAHKT(2,2+IIGLU1)=0
38133       PHKT(1,2+IIGLU1)  =PHKK(1,NC2T)
38134      *+XGIVE*PHKT(1,5+IIGLU1)
38135       PHKT(2,2+IIGLU1)  =PHKK(2,NC2T)
38136      *+XGIVE*PHKT(2,5+IIGLU1)
38137       PHKT(3,2+IIGLU1)  =PHKK(3,NC2T)
38138      *+XGIVE*PHKT(3,5+IIGLU1)
38139       PHKT(4,2+IIGLU1)  =PHKK(4,NC2T)
38140      *+XGIVE*PHKT(4,5+IIGLU1)
38141 C     PHKT(5,2)  =PHKK(5,NC2T)
38142       XMIST=(PHKT(4,2+IIGLU1)**2-
38143      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38144      *PHKT(1,2+IIGLU1)**2)
38145       IF(XMIST.GT.0.D0)THEN
38146       PHKT(5,2+IIGLU1)  =SQRT(PHKT(4,2+IIGLU1)**2-
38147      * PHKT(3,2+IIGLU1)**2-PHKT(2,2+IIGLU1)**2-
38148      *PHKT(1,2+IIGLU1)**2)
38149       ELSE
38150 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38151       PHKT(5,2+IIGLU1)=0.D0
38152       ENDIF
38153       VHKT(1,2+IIGLU1)  =VHKK(1,NC2T)
38154       VHKT(2,2+IIGLU1)  =VHKK(2,NC2T)
38155       VHKT(3,2+IIGLU1)  =VHKK(3,NC2T)
38156       VHKT(4,2+IIGLU1)  =VHKK(4,NC2T)
38157       WHKT(1,2+IIGLU1)  =WHKK(1,NC2T)
38158       WHKT(2,2+IIGLU1)  =WHKK(2,NC2T)
38159       WHKT(3,2+IIGLU1)  =WHKK(3,NC2T)
38160       WHKT(4,2+IIGLU1)  =WHKK(4,NC2T)
38161       IDHKT(3+IIGLU1)   =88888
38162 C     IDHKT(3)   =1000*NNNC1+MMMC1+10
38163       ISTHKT(3+IIGLU1)  =93
38164 C     ISTHKT(3)  =KKKC1
38165       JMOHKT(1,3+IIGLU1)=1
38166       JMOHKT(2,3+IIGLU1)=2+IIGLU1
38167       JDAHKT(1,3+IIGLU1)=0
38168       JDAHKT(2,3+IIGLU1)=0
38169       PHKT(1,3+IIGLU1)  =PHKT(1,1)+PHKT(1,2+IIGLU1)+PG1
38170       PHKT(2,3+IIGLU1)  =PHKT(2,1)+PHKT(2,2+IIGLU1)+PG2
38171       PHKT(3,3+IIGLU1)  =PHKT(3,1)+PHKT(3,2+IIGLU1)+PG3
38172       PHKT(4,3+IIGLU1)  =PHKT(4,1)+PHKT(4,2+IIGLU1)+PG4
38173       PHKT(5,3+IIGLU1)
38174      * =SQRT(PHKT(4,3+IIGLU1)**2-PHKT(1,3+IIGLU1)**2-PHKT(2,3+IIGLU1)**2
38175      *            -PHKT(3,3+IIGLU1)**2)
38176       IF(IPIP.GE.3)THEN
38177       WRITE(LOUT,*)1,ISTHKT(1),IDHKT(1),JMOHKT(1,1),JMOHKT(2,1),
38178      * JDAHKT(1,1),
38179      *JDAHKT(2,1),(PHKT(III,1),III=1,5)
38180       DO 71 IIG=2,2+IIGLU1-1
38181       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38182      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38183      * JDAHKT(1,IIG),
38184      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38185    71 CONTINUE
38186       WRITE(LOUT,*)2+IIGLU1,ISTHKT(2+IIGLU1),
38187      &             IDHKT(2),JMOHKT(1,2+IIGLU1),
38188      * JMOHKT(2,2+IIGLU1),JDAHKT(1,2+IIGLU1),
38189      *JDAHKT(2,2+IIGLU1),(PHKT(III,2+IIGLU1),III=1,5)
38190       WRITE(LOUT,*)3+IIGLU1,ISTHKT(3+IIGLU1),IDHKT(3+IIGLU1),
38191      * JMOHKT(1,3+IIGLU1),
38192      * JMOHKT(2,3+IIGLU1),JDAHKT(1,3+IIGLU1),
38193      *JDAHKT(2,3+IIGLU1),(PHKT(III,3+IIGLU1),III=1,5)
38194       ENDIF
38195       CHAMAL=CHAB1
38196 **NEW
38197 C     IF(IPIP.EQ.1)THEN
38198 C       IF(IPP21.GE.3.OR.IPP22.GE.3.OR.IP11.GE.3)CHAMAL=CHAB3
38199 C     ELSEIF(IPIP.EQ.2)THEN
38200 C       IF(IPP21.LE.-3.OR.IPP22.LE.-3.OR.IP11.LE.-3)CHAMAL=CHAB3
38201 C     ENDIF
38202       IF(IPIP.EQ.1)THEN
38203         IF(KK21.GE.3.OR.KK22.GE.3.OR.KK11.GE.3)CHAMAL=CHAB3
38204       ELSEIF(IPIP.EQ.2)THEN
38205         IF(KK21.LE.-3.OR.KK22.LE.-3.OR.KK11.LE.-3)CHAMAL=CHAB3
38206       ENDIF
38207 **
38208       IF(PHKT(5,3+IIGLU1).LT.CHAMAL)THEN
38209 C       IREJ=1
38210         IPCO=0
38211 C       RETURN
38212 C       WRITE(6,*)' MGSQBS1 jump back from chain 3'
38213         GO TO 3466
38214       ENDIF
38215       VHKT(1,3+IIGLU1)  =VHKK(1,NC1)
38216       VHKT(2,3+IIGLU1)  =VHKK(2,NC1)
38217       VHKT(3,3+IIGLU1)  =VHKK(3,NC1)
38218       VHKT(4,3+IIGLU1)  =VHKK(4,NC1)
38219       WHKT(1,3+IIGLU1)  =WHKK(1,NC1)
38220       WHKT(2,3+IIGLU1)  =WHKK(2,NC1)
38221       WHKT(3,3+IIGLU1)  =WHKK(3,NC1)
38222       WHKT(4,3+IIGLU1)  =WHKK(4,NC1)
38223       IF(IPIP.EQ.1)THEN
38224         IDHKT(7+IIGLU1)   =1000*IPP1+100*ISQ1+3
38225         IF(IDHKT(7+IIGLU1).EQ.1203)IDHKT(7+IIGLU1)=2103
38226         IF(IDHKT(7+IIGLU1).EQ.1303)IDHKT(7+IIGLU1)=3103
38227         IF(IDHKT(7+IIGLU1).EQ.2303)IDHKT(7+IIGLU1)=3203
38228       ELSEIF(IPIP.EQ.2)THEN
38229         IDHKT(7+IIGLU1)   =1000*IPP1+100*(-ISQ1+6)-3
38230         IF(IDHKT(7+IIGLU1).EQ.-1203)IDHKT(7+IIGLU1)=-2103
38231         IF(IDHKT(7+IIGLU1).EQ.-1303)IDHKT(7+IIGLU1)=-3103
38232         IF(IDHKT(7+IIGLU1).EQ.-2303)IDHKT(7+IIGLU1)=-3203
38233 C       WRITE(6,*)'IDHKT(7),IPP1,ISQ1',IDHKT(7),IPP1,ISQ1
38234       ENDIF
38235       ISTHKT(7+IIGLU1)  =921
38236       JMOHKT(1,7+IIGLU1)=NC2P
38237       JMOHKT(2,7+IIGLU1)=0
38238       JDAHKT(1,7+IIGLU1)=9+IIGLU1+IIGLU2
38239       JDAHKT(2,7+IIGLU1)=0
38240 C     PHKT(1,7)  =0.5D0*PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ/(XDIQP+XSQ)
38241 C     PHKT(2,7)  =0.5D0*PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ/(XDIQP+XSQ)
38242 C     PHKT(3,7)  =0.5D0*PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ/(XDIQP+XSQ)
38243 C     PHKT(4,7+IIGLU1)  =0.5D0*PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ/(XDIQP+XSQ)
38244 **NEW
38245       IF ((XSQ1 .LT.0.0D0).OR.(XDIQP .LT.0.0D0))
38246      &    WRITE(LOUT,*) ' mgsqbs3: ',XSQ1,XDIQP
38247 **
38248       PHKT(1,7+IIGLU1)  =PHKK(1,NC2P)+PHKK(1,NC1P)*XSQ1/(XDIQP+XSQ1)
38249       PHKT(2,7+IIGLU1)  =PHKK(2,NC2P)+PHKK(2,NC1P)*XSQ1/(XDIQP+XSQ1)
38250       PHKT(3,7+IIGLU1)  =PHKK(3,NC2P)+PHKK(3,NC1P)*XSQ1/(XDIQP+XSQ1)
38251       PHKT(4,7+IIGLU1)  =PHKK(4,NC2P)+PHKK(4,NC1P)*XSQ1/(XDIQP+XSQ1)
38252 C     WRITE(6,*)'PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)',
38253 C    * PHKK(4,NC1P),PHKK(4,NC2P), PHKT(4,7)
38254       IF(PHKT(4,7+IIGLU1).GE. PHKK(4,NC1P))THEN
38255 C       IREJ=1
38256 C       WRITE(6,*)'reject PHKT(4,7).GE. PHKK(4,NC1P)'
38257         IPCO=0
38258 C       RETURN
38259         GO TO 3466
38260       ENDIF
38261 C     PHKT(5,7)  =PHKK(5,NC2P)
38262       PHKT(5,7+IIGLU1)  =SQRT(PHKT(4,7+IIGLU1)**2-
38263      * PHKT(3,7+IIGLU1)**2-PHKT(2,7+IIGLU1)**2-
38264      *PHKT(1,7+IIGLU1)**2)
38265       VHKT(1,7+IIGLU1)  =VHKK(1,NC2P)
38266       VHKT(2,7+IIGLU1)  =VHKK(2,NC2P)
38267       VHKT(3,7+IIGLU1)  =VHKK(3,NC2P)
38268       VHKT(4,7+IIGLU1)  =VHKK(4,NC2P)
38269       WHKT(1,7+IIGLU1)  =WHKK(1,NC2P)
38270       WHKT(2,7+IIGLU1)  =WHKK(2,NC2P)
38271       WHKT(3,7+IIGLU1)  =WHKK(3,NC2P)
38272       WHKT(4,7+IIGLU1)  =WHKK(4,NC2P)
38273 C     Insert here the IIGLU2 gluons
38274       PG1=0.D0
38275       PG2=0.D0
38276       PG3=0.D0
38277       PG4=0.D0
38278       IF(IIGLU2.GE.1)THEN
38279       JJG=NC2P
38280       DO 81 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38281         KKG=JJG+IIG-7-IIGLU1
38282         IDHKT(IIG)   =IDHKK(KKG)
38283         ISTHKT(IIG)  =921
38284         JMOHKT(1,IIG)=KKG
38285         JMOHKT(2,IIG)=0
38286         JDAHKT(1,IIG)=9+IIGLU1+IIGLU2
38287         JDAHKT(2,IIG)=0
38288         PHKT(1,IIG)=PHKK(1,KKG)
38289         PG1=PG1+ PHKT(1,IIG)
38290         PHKT(2,IIG)=PHKK(2,KKG)
38291         PG2=PG2+ PHKT(2,IIG)
38292         PHKT(3,IIG)=PHKK(3,KKG)
38293         PG3=PG3+ PHKT(3,IIG)
38294         PHKT(4,IIG)=PHKK(4,KKG)
38295         PG4=PG4+ PHKT(4,IIG)
38296         PHKT(5,IIG)=PHKK(5,KKG)
38297         VHKT(1,IIG)  =VHKK(1,KKG)
38298         VHKT(2,IIG)  =VHKK(2,KKG)
38299         VHKT(3,IIG)  =VHKK(3,KKG)
38300         VHKT(4,IIG)  =VHKK(4,KKG)
38301         WHKT(1,IIG)  =WHKK(1,KKG)
38302         WHKT(2,IIG)  =WHKK(2,KKG)
38303         WHKT(3,IIG)  =WHKK(3,KKG)
38304         WHKT(4,IIG)  =WHKK(4,KKG)
38305    81 CONTINUE
38306       ENDIF
38307       IDHKT(8+IIGLU1+IIGLU2)   =IP2
38308       ISTHKT(8+IIGLU1+IIGLU2)  =922
38309       JMOHKT(1,8+IIGLU1+IIGLU2)=NC1T
38310       JMOHKT(2,8+IIGLU1+IIGLU2)=0
38311       JDAHKT(1,8+IIGLU1+IIGLU2)=9+IIGLU1+IIGLU2
38312       JDAHKT(2,8+IIGLU1+IIGLU2)=0
38313 **NEW
38314       IF ((XVQT.LT.0.0D0).OR.(XSAQ1 .LT.0.0D0))
38315      &    WRITE(LOUT,*) ' mgsqbs4: ',XVQT,XSAQ1
38316 **
38317       PHKT(1,8+IIGLU1+IIGLU2)  =PHKK(1,NC1T)*XVQT/(XSAQ1+XVQT)
38318       PHKT(2,8+IIGLU1+IIGLU2)  =PHKK(2,NC1T)*XVQT/(XSAQ1+XVQT)
38319       PHKT(3,8+IIGLU1+IIGLU2)  =PHKK(3,NC1T)*XVQT/(XSAQ1+XVQT)
38320       PHKT(4,8+IIGLU1+IIGLU2)  =PHKK(4,NC1T)*XVQT/(XSAQ1+XVQT)
38321 C     PHKT(5,8+IIGLU1+IIGLU2)  =PHKK(5,NC1T)
38322       XMIST=(PHKT(4,8+IIGLU1+IIGLU2)**2-
38323      * PHKT(3,8+IIGLU1+IIGLU2)**2-PHKT(2,8+IIGLU1+IIGLU2)**2-
38324      *PHKT(1,8+IIGLU1+IIGLU2)**2)
38325       IF(XMIST.GT.0.D0)THEN
38326       PHKT(5,8+IIGLU1+IIGLU2)  =SQRT(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       ELSE
38330 C     WRITE(6,*)'MUSQBS2 parton 1 mass square LT.0 ',XMIST
38331       PHKT(5,8+IIGLU1+IIGLU2)=0.D0
38332       ENDIF
38333       VHKT(1,8+IIGLU1+IIGLU2)  =VHKK(1,NC1T)
38334       VHKT(2,8+IIGLU1+IIGLU2)  =VHKK(2,NC1T)
38335       VHKT(3,8+IIGLU1+IIGLU2)  =VHKK(3,NC1T)
38336       VHKT(4,8+IIGLU1+IIGLU2)  =VHKK(4,NC1T)
38337       WHKT(1,8+IIGLU1+IIGLU2)  =WHKK(1,NC1T)
38338       WHKT(2,8+IIGLU1+IIGLU2)  =WHKK(2,NC1T)
38339       WHKT(3,8+IIGLU1+IIGLU2)  =WHKK(3,NC1T)
38340       WHKT(4,8+IIGLU1+IIGLU2)  =WHKK(4,NC1T)
38341       IDHKT(9+IIGLU1+IIGLU2)   =88888
38342 C     IDHKT(9)   =1000*NNNC2+MMMC2+10
38343       ISTHKT(9+IIGLU1+IIGLU2)  =93
38344 C     ISTHKT(9)  =KKKC2
38345       JMOHKT(1,9+IIGLU1+IIGLU2)=7+IIGLU1
38346       JMOHKT(2,9+IIGLU1+IIGLU2)=8+IIGLU1+IIGLU2
38347       JDAHKT(1,9+IIGLU1+IIGLU2)=0
38348       JDAHKT(2,9+IIGLU1+IIGLU2)=0
38349       PHKT(1,9+IIGLU1+IIGLU2)  =PHKT(1,7+IIGLU1)
38350      * +PHKT(1,8+IIGLU1+IIGLU2)+PG1
38351       PHKT(2,9+IIGLU1+IIGLU2)  =PHKT(2,7+IIGLU1)
38352      * +PHKT(2,8+IIGLU1+IIGLU2)+PG2
38353       PHKT(3,9+IIGLU1+IIGLU2)  =PHKT(3,7+IIGLU1)
38354      * +PHKT(3,8+IIGLU1+IIGLU2)+PG3
38355       PHKT(4,9+IIGLU1+IIGLU2)  =PHKT(4,7+IIGLU1)
38356      * +PHKT(4,8+IIGLU1+IIGLU2)+PG4
38357       PHKT(5,9+IIGLU1+IIGLU2)
38358      * =SQRT(PHKT(4,9+IIGLU1+IIGLU2)**2-PHKT(1,9+IIGLU1+IIGLU2)**2-
38359      * PHKT(2,9+IIGLU1+IIGLU2)**2
38360      *            -PHKT(3,9+IIGLU1+IIGLU2)**2)
38361       IF(IPIP.GE.3)THEN
38362       WRITE(LOUT,*)7+IIGLU1,ISTHKT(7+IIGLU1),IDHKT(7+IIGLU1),
38363      * JMOHKT(1,7+IIGLU1),
38364      * JMOHKT(2,7+IIGLU1),JDAHKT(1,7+IIGLU1),
38365      *JDAHKT(2,7+IIGLU1),(PHKT(III,7+IIGLU1),III=1,5)
38366       DO 91 IIG=7+IIGLU1+1,7+IIGLU1+IIGLU2
38367       WRITE(LOUT,*)IIG,ISTHKT(IIG),IDHKT(IIG),
38368      &             JMOHKT(1,IIG),JMOHKT(2,IIG),
38369      * JDAHKT(1,IIG),
38370      *JDAHKT(2,IIG),(PHKT(III,IIG),III=1,5)
38371    91 CONTINUE
38372       WRITE(LOUT,*)8+IIGLU1+IIGLU2,ISTHKT(8+IIGLU1+IIGLU2),
38373      * IDHKT(8+IIGLU1+IIGLU2),
38374      * JMOHKT(1,8+IIGLU1+IIGLU2),JMOHKT(2,8+IIGLU1+IIGLU2),
38375      * JDAHKT(1,8+IIGLU1+IIGLU2),
38376      *JDAHKT(2,8+IIGLU1+IIGLU2),(PHKT(III,8+IIGLU1+IIGLU2),III=1,5)
38377       WRITE(LOUT,*)9+IIGLU1+IIGLU2,ISTHKT(9+IIGLU1+IIGLU2),
38378      * IDHKT(9+IIGLU1+IIGLU2),
38379      * JMOHKT(1,9+IIGLU1+IIGLU2),JMOHKT(2,9+IIGLU1+IIGLU2),
38380      * JDAHKT(1,9+IIGLU1+IIGLU2),
38381      *JDAHKT(2,9+IIGLU1+IIGLU2),(PHKT(III,9+IIGLU1+IIGLU2),III=1,5)
38382       ENDIF
38383       CHAMAL=CHAB1
38384       IF(IPIP.EQ.1)THEN
38385         IF(IP2.GE.3.OR.IPP1.GE.3.OR.ISQ1.GE.3)CHAMAL=CHAB3
38386       ELSEIF(IPIP.EQ.2)THEN
38387         IF(IP2.LE.-3.OR.IPP1.LE.-3.OR.ISQ1.GE.9)CHAMAL=CHAB3
38388       ENDIF
38389       IF(PHKT(5,9+IIGLU1+IIGLU2).LT.CHAMAL)THEN
38390 C       IREJ=1
38391         IPCO=0
38392 C       RETURN
38393 C       WRITE(6,*)' MGSQBS1 jump back from chain 9',
38394 C    &  'CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)',CHAMAL,PHKT(5,9+IIGLU1+IIGLU2)
38395         GO TO 3466
38396       ENDIF
38397       VHKT(1,9+IIGLU1+IIGLU2)  =VHKK(1,NC1)
38398       VHKT(2,9+IIGLU1+IIGLU2)  =VHKK(2,NC1)
38399       VHKT(3,9+IIGLU1+IIGLU2)  =VHKK(3,NC1)
38400       VHKT(4,9+IIGLU1+IIGLU2)  =VHKK(4,NC1)
38401       WHKT(1,9+IIGLU1+IIGLU2)  =WHKK(1,NC1)
38402       WHKT(2,9+IIGLU1+IIGLU2)  =WHKK(2,NC1)
38403       WHKT(3,9+IIGLU1+IIGLU2)  =WHKK(3,NC1)
38404       WHKT(4,9+IIGLU1+IIGLU2)  =WHKK(4,NC1)
38405 C
38406       IGCOUN=9+IIGLU1+IIGLU2
38407       IPCO=0
38408        RETURN
38409        END
38410
38411 *$ CREATE HKKHKT.FOR
38412 *COPY HKKHKT
38413 C
38414 C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
38415 C
38416       SUBROUTINE HKKHKT(I,J)
38417       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38418       SAVE
38419
38420 * event history
38421
38422       PARAMETER (NMXHKK=200000)
38423
38424       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38425      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38426      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38427
38428 * extended event history
38429       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38430      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38431      &                IHIST(2,NMXHKK)
38432
38433       PARAMETER (NTMHKK= 300)
38434       COMMON /HKKTMP/NHKKT,NEVHKT,ISTHKT(NTMHKK),IDHKT(NTMHKK),JMOHKT
38435      +(2,NTMHKK),JDAHKT(2,NTMHKK), PHKT(5,NTMHKK),VHKT(4,NTMHKK),WHKT
38436      +(4,NTMHKK)
38437 C
38438       ISTHKK(I)  =ISTHKT(J)
38439       IDHKK(I)   =IDHKT(J)
38440 C     IF(J.EQ.3.OR.J.EQ.6.OR.J.EQ.9)THEN
38441       IF(IDHKK(I).EQ.88888)THEN
38442 C       JMOHKK(1,I)=I-2
38443 C       JMOHKK(2,I)=I-1
38444         JMOHKK(1,I)=I-(J-JMOHKT(1,J))
38445         JMOHKK(2,I)=I-(J-JMOHKT(2,J))
38446       ELSE
38447         JMOHKK(1,I)=JMOHKT(1,J)
38448         JMOHKK(2,I)=JMOHKT(2,J)
38449       ENDIF
38450       JDAHKK(1,I)=JDAHKT(1,J)
38451       JDAHKK(2,I)=JDAHKT(2,J)
38452 C       IF(J.EQ.1.OR.J.EQ.4.OR.J.EQ.7)THEN
38453 C       JDAHKK(1,I)=I+2
38454 C     ELSEIF(J.EQ.2.OR.J.EQ.5.OR.J.EQ.8)THEN
38455 C       JDAHKK(1,I)=I+1
38456 C     ENDIF
38457       IF(JDAHKT(1,J).GT.0)THEN
38458         JDAHKK(1,I)=I+(JDAHKT(1,J)-J)
38459       ENDIF
38460       PHKK(1,I)  =PHKT(1,J)
38461       PHKK(2,I)  =PHKT(2,J)
38462       PHKK(3,I)  =PHKT(3,J)
38463       PHKK(4,I)  =PHKT(4,J)
38464       PHKK(5,I)  =PHKT(5,J)
38465       VHKK(1,I)  =VHKT(1,J)
38466       VHKK(2,I)  =VHKT(2,J)
38467       VHKK(3,I)  =VHKT(3,J)
38468       VHKK(4,I)  =VHKT(4,J)
38469       WHKK(1,I)  =WHKT(1,J)
38470       WHKK(2,I)  =WHKT(2,J)
38471       WHKK(3,I)  =WHKT(3,J)
38472       WHKK(4,I)  =WHKT(4,J)
38473       RETURN
38474       END
38475
38476 *$ CREATE DT_DBREAK.FOR
38477 *COPY DT_DBREAK
38478 *
38479 *===dbreak=============================================================*
38480 *
38481       SUBROUTINE DT_DBREAK(MODE)
38482
38483 ************************************************************************
38484 * This is the steering subroutine for the different diquark breaking   *
38485 * mechanisms.                                                          *
38486 *                                                                      *
38487 * MODE = 1  breaking of projectile diquark in qq-q chain using         *
38488 *           a sea quark (q-qq chain) of the same projectile            *
38489 *      = 2  breaking of target     diquark in q-qq chain using         *
38490 *           a sea quark (qq-q chain) of the same target                *
38491 *      = 3  breaking of projectile diquark in qq-q chain using         *
38492 *           a sea quark (q-aq chain) of the same projectile            *
38493 *      = 4  breaking of target     diquark in q-qq chain using         *
38494 *           a sea quark (aq-q chain) of the same target                *
38495 *      = 5  breaking of projectile anti-diquark in aqaq-aq chain using *
38496 *           a sea anti-quark (aq-aqaq chain) of the same projectile    *
38497 *      = 6  breaking of target     anti-diquark in aq-aqaq chain using *
38498 *           a sea anti-quark (aqaq-aq chain) of the same target        *
38499 *      = 7  breaking of projectile anti-diquark in aqaq-aq chain using *
38500 *           a sea anti-quark (aq-q chain) of the same projectile       *
38501 *      = 8  breaking of target     anti-diquark in aq-aqaq chain using *
38502 *           a sea anti-quark (q-aq chain) of the same target           *
38503 *                                                                      *
38504 * Original version by J. Ranft.                                        *
38505 * This version dated 17.5.00  is written by S. Roesler.                *
38506 ************************************************************************
38507
38508       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38509       SAVE
38510
38511       PARAMETER ( LINP = 10 ,
38512      &            LOUT = 6 ,
38513      &            LDAT = 9 )
38514
38515 * event history
38516
38517       PARAMETER (NMXHKK=200000)
38518
38519       COMMON /DTEVT1/ NHKK,NEVHKK,ISTHKK(NMXHKK),IDHKK(NMXHKK),
38520      &                JMOHKK(2,NMXHKK),JDAHKK(2,NMXHKK),
38521      &                PHKK(5,NMXHKK),VHKK(4,NMXHKK),WHKK(4,NMXHKK)
38522
38523 * extended event history
38524       COMMON /DTEVT2/ IDRES(NMXHKK),IDXRES(NMXHKK),NOBAM(NMXHKK),
38525      &                IDBAM(NMXHKK),IDCH(NMXHKK),NPOINT(10),
38526      &                IHIST(2,NMXHKK)
38527
38528 * flags for input different options
38529       LOGICAL LEMCCK,LHADRO,LSEADI,LEVAPO
38530       COMMON /DTFLG1/ IFRAG(2),IRESCO,IMSHL,IRESRJ,IOULEV(6),
38531      &                LEMCCK,LHADRO(0:9),LSEADI,LEVAPO,IFRAME,ITRSPT
38532
38533 * pointer to chains in hkkevt common (used by qq-breaking mechanisms)
38534       PARAMETER (MAXCHN=10000)
38535       COMMON /DTIXCH/ IDXCHN(2,MAXCHN),NCHAIN
38536
38537 * diquark-breaking mechanism
38538       COMMON /DTDIQB/ DBRKR(3,8),DBRKA(3,8),CHAM1,CHAM3,CHAB1,CHAB3
38539
38540 * flags for particle decays
38541       COMMON /DTFRPA/ MSTUX(20),PARUX(20),MSTJX(20),PARJX(20),
38542      &                IMSTU(20),IPARU(20),IMSTJ(20),IPARJ(20),
38543      &                NMSTU,NPARU,NMSTJ,NPARJ,PDB,PDBSEA(3),ISIG0,IPI0
38544
38545 *
38546 * chain identifiers
38547 * ( 1 = q-aq,   2 = aq-q,   3 = q-qq,   4 = qq-q,
38548 *   5 = aq-adq, 6 = adq-aq, 7 = dq-adq, 8 = adq-dq )
38549       DIMENSION IDCHN1(8),IDCHN2(8)
38550       DATA IDCHN1 / 4, 3, 4, 3, 6, 5, 6, 5/
38551       DATA IDCHN2 / 3, 4, 1, 2, 5, 6, 2, 1/
38552 *
38553 * parton identifiers
38554 * ( +-21/22 = valence, +-31/32 = Glauber-sea, +-41/42 = Pomeron (diff),
38555 *   +-51/52 = unitarity-sea, +-61/62 = gluons )
38556       DIMENSION ISP1P(8,3),ISP1T(8,3),ISP2P(8,3),ISP2T(8,3)
38557       DATA ISP1P / 21, 21, 21, 21, 21, 21, 21, 21,
38558      &             31, 31, 31, 31, 31, 31, 31, 31,
38559      &             41, 41, 41, 41, 51, 51, 51, 51/
38560       DATA ISP1T / 22, 22, 22, 22, 22, 22, 22, 22,
38561      &             32, 32, 32, 32, 32, 32, 32, 32,
38562      &             42, 42, 42, 42, 52, 52, 52, 52/
38563       DATA ISP2P / 31, 21, 31, 31, 21, 21, 21, 21,
38564      &             51, 31, 41, 41, 31, 31, 31, 31,
38565      &              0, 41, 51, 51, 51, 51, 51, 51/
38566       DATA ISP2T / 22, 32, 32, 32, 22, 22, 22, 22,
38567      &             32, 52, 42, 42, 32, 32, 32, 32,
38568      &             42,  0, 52, 52, 52, 52, 52, 52/
38569
38570       IF (NCHAIN.LE.0) RETURN
38571       DO 1 I=1,NCHAIN
38572          IDX1 = IDXCHN(1,I)
38573          IS1P = ABS(ISTHKK(JMOHKK(1,IDX1)))
38574          IS1T = ABS(ISTHKK(JMOHKK(2,IDX1)))
38575          IF ( (IDXCHN(2,I).EQ.IDCHN1(MODE))
38576      &       .AND.
38577      &        ((IS1P.EQ.ISP1P(MODE,1)).OR.(IS1P.EQ.ISP1P(MODE,2)).OR.
38578      &                                    (IS1P.EQ.ISP1P(MODE,3)))
38579      &       .AND.
38580      &        ((IS1T.EQ.ISP1T(MODE,1)).OR.(IS1T.EQ.ISP1T(MODE,2)).OR.
38581      &                                    (IS1T.EQ.ISP1T(MODE,3)))
38582      &      ) THEN
38583             DO 2 J=1,NCHAIN
38584                IDX2 = IDXCHN(1,J)
38585                IS2P = ABS(ISTHKK(JMOHKK(1,IDX2)))
38586                IS2T = ABS(ISTHKK(JMOHKK(2,IDX2)))
38587                IF ( (IDXCHN(2,J).EQ.IDCHN2(MODE))
38588      &             .AND.
38589      &              ((IS2P.EQ.ISP2P(MODE,1)).OR.(IS2P.EQ.ISP2P(MODE,2))
38590      &                                      .OR.(IS2P.EQ.ISP2P(MODE,3)))
38591      &             .AND.
38592      &              ((IS2T.EQ.ISP2T(MODE,1)).OR.(IS2T.EQ.ISP2T(MODE,2))
38593      &                                      .OR.(IS2T.EQ.ISP2T(MODE,3)))
38594      &            ) THEN
38595 *   find mother nucleons of the diquark to be splitted and of the
38596 *   sea-quark and reject this combination if it is not the same
38597                   IF ((MODE.EQ.1).OR.(MODE.EQ.3).OR.
38598      &                (MODE.EQ.5).OR.(MODE.EQ.7)) THEN
38599                      IANCES = 1
38600                   ELSE
38601                      IANCES = 2
38602                   ENDIF
38603                   IDXMO1 = JMOHKK(IANCES,IDX1)
38604     4             CONTINUE
38605                   IF ((JMOHKK(1,IDXMO1).NE.0).AND.
38606      &                (JMOHKK(2,IDXMO1).NE.0)) THEN
38607                      IANC = IANCES
38608                   ELSE
38609                      IANC = 1
38610                   ENDIF
38611                   IF (JMOHKK(IANC,IDXMO1).NE.0) THEN
38612                      IDXMO1 = JMOHKK(IANC,IDXMO1)
38613                      GOTO 4
38614                   ENDIF
38615                   IDXMO2 = JMOHKK(IANCES,IDX2)
38616     5             CONTINUE
38617                   IF ((JMOHKK(1,IDXMO2).NE.0).AND.
38618      &                (JMOHKK(2,IDXMO2).NE.0)) THEN
38619                      IANC = IANCES
38620                   ELSE
38621                      IANC = 1
38622                   ENDIF
38623                   IF (JMOHKK(IANC,IDXMO2).NE.0) THEN
38624                      IDXMO2 = JMOHKK(IANC,IDXMO2)
38625                      GOTO 5
38626                   ENDIF
38627                   IF (IDXMO1.NE.IDXMO2) GOTO 2
38628 *   quark content of projectile parton
38629                   IP1   = IDHKK(JMOHKK(1,IDX1))
38630                   IP11  = IP1/1000
38631                   IP12  = (IP1-1000*IP11)/100
38632                   IP2   = IDHKK(JMOHKK(2,IDX1))
38633                   IP21  = IP2/1000
38634                   IP22  = (IP2-1000*IP21)/100
38635 *   quark content of target parton
38636                   IT1  = IDHKK(JMOHKK(1,IDX2))
38637                   IT11 = IT1/1000
38638                   IT12 = (IT1-1000*IT11)/100
38639                   IT2  = IDHKK(JMOHKK(2,IDX2))
38640                   IT21 = IT2/1000
38641                   IT22 = (IT2-1000*IT21)/100
38642 *   split diquark and form new chains
38643                   IF (MODE.EQ.1) THEN
38644                      IF (IT1.EQ.4) GOTO 2
38645                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38646      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38647      &                         IP11,IP12,IP2,IT1,IT21,IT22,1,IPQ,IGCOUN)
38648                   ELSEIF (MODE.EQ.2) THEN
38649                      IF (IT2.EQ.4) GOTO 2
38650                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38651      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38652      &                         IP1,IP21,IP22,IT11,IT12,IT2,1,IPQ,IGCOUN)
38653                   ELSEIF (MODE.EQ.3) THEN
38654                      IF (IT1.EQ.4) GOTO 2
38655                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38656      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38657      &                         IP11,IP12,IP2,IT1,IT2,1,IPQ,IGCOUN)
38658                   ELSEIF (MODE.EQ.4) THEN
38659                      IF (IT2.EQ.4) GOTO 2
38660                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38661      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38662      &                         IP1,IP21,IP22,IT1,IT2,1,IPQ,IGCOUN)
38663                   ELSEIF (MODE.EQ.5) THEN
38664                      CALL MGSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38665      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38666      &                         IP11,IP12,IP2,IT1,IT21,IT22,2,IPQ,IGCOUN)
38667                   ELSEIF (MODE.EQ.6) THEN
38668                      CALL MGSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38669      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38670      &                         IP1,IP21,IP22,IT11,IT12,IT2,2,IPQ,IGCOUN)
38671                   ELSEIF (MODE.EQ.7) THEN
38672                      CALL MUSQBS1(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38673      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38674      &                         IP11,IP12,IP2,IT1,IT2,2,IPQ,IGCOUN)
38675                   ELSEIF (MODE.EQ.8) THEN
38676                      CALL MUSQBS2(IDX1,JMOHKK(1,IDX1),JMOHKK(2,IDX1),
38677      &                         IDX2,JMOHKK(1,IDX2),JMOHKK(2,IDX2),IREJ,
38678      &                         IP1,IP21,IP22,IT1,IT2,2,IPQ,IGCOUN)
38679                   ENDIF
38680                   IF (IREJ.GE.1) THEN
38681                      if ((ipq.lt.0).or.(ipq.ge.4))
38682      &                  write(LOUT,*) 'ipq !!!',ipq,mode
38683                      DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38684 *   accept or reject new chains corresponding to PDBSEA
38685                   ELSE
38686                      IF ((IPQ.EQ.1).OR.(IPQ.EQ.2)) THEN
38687                         ACC   = DBRKA(1,MODE)+DBRKA(2,MODE)
38688                         REJ   = DBRKR(1,MODE)+DBRKR(2,MODE)
38689                      ELSEIF (IPQ.EQ.3) THEN
38690                         ACC   = DBRKA(3,MODE)
38691                         REJ   = DBRKR(3,MODE)
38692                      ELSE
38693                         WRITE(LOUT,*) ' inconsistent IPQ ! ',IPQ
38694                         STOP
38695                      ENDIF
38696                      IF (ACC/(ACC+REJ).LE.PDBSEA(IPQ)) THEN
38697                         DBRKA(IPQ,MODE) = DBRKA(IPQ,MODE)+1.0D0
38698                         IACC = 1
38699                      ELSE
38700                         DBRKR(IPQ,MODE) = DBRKR(IPQ,MODE)+1.0D0
38701                         IACC = 0
38702                      ENDIF
38703 *   new chains have been accepted and are now copied into HKKEVT
38704                      IF (IACC.EQ.1) THEN
38705                         IF (LEMCCK) THEN
38706                            CALL DT_EVTEMC(PHKK(1,IDX1),PHKK(2,IDX1),
38707      &                                    PHKK(3,IDX1),PHKK(4,IDX1),
38708      &                                    1,IDUM1,IDUM2)
38709                            CALL DT_EVTEMC(PHKK(1,IDX2),PHKK(2,IDX2),
38710      &                                    PHKK(3,IDX2),PHKK(4,IDX2),
38711      &                                    2,IDUM1,IDUM2)
38712                         ENDIF
38713                         IDHKK(IDX1) = 99888
38714                         IDHKK(IDX2) = 99888
38715                         IDXCHN(2,I) = -1
38716                         IDXCHN(2,J) = -1
38717                         DO 3 K=1,IGCOUN
38718                            NHKK = NHKK+1
38719                            CALL HKKHKT(NHKK,K)
38720                            IF ((LEMCCK).AND.(IDHKK(NHKK).EQ.88888))THEN
38721                               PX = -PHKK(1,NHKK)
38722                               PY = -PHKK(2,NHKK)
38723                               PZ = -PHKK(3,NHKK)
38724                               PE = -PHKK(4,NHKK)
38725                               CALL DT_EVTEMC(PX,PY,PZ,PE,2,IDUM1,IDUM2)
38726                            ENDIF
38727     3                   CONTINUE
38728                         IF (LEMCCK) THEN
38729                            CHKLEV = 0.1D0
38730                            CALL DT_EVTEMC(DUM1,DUM2,DUM3,CHKLEV,-1,9000,
38731      &                                                             IREJ)
38732                            IF (IREJ.NE.0) CALL DT_EVTOUT(4)
38733                         ENDIF
38734                         GOTO 1
38735                      ENDIF
38736                   ENDIF
38737                ENDIF
38738     2       CONTINUE
38739          ENDIF
38740     1 CONTINUE
38741       RETURN
38742       END
38743
38744 *$ CREATE DT_CQPAIR.FOR
38745 *COPY DT_CQPAIR
38746 *
38747 *===cqpair=============================================================*
38748 *
38749       SUBROUTINE DT_CQPAIR(XQMAX,XAQMAX,XQ,XAQ,IFLV,IREJ)
38750
38751 ************************************************************************
38752 * This subroutine Creates a Quark-antiquark PAIR from the sea.         *
38753 *                                                                      *
38754 *   XQMAX   maxium energy fraction of quark (input)                    *
38755 *   XAQMAX  maxium energy fraction of antiquark (input)                *
38756 *   XQ      energy fraction of quark (output)                          *
38757 *   XAQ     energy fraction of antiquark (output)                      *
38758 *   IFLV    quark flavour (- antiquark flavor) (output)                *
38759 *                                                                      *
38760 * This version dated 14.5.00  is written by S. Roesler.                *
38761 ************************************************************************
38762
38763       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
38764       SAVE
38765
38766       PARAMETER ( LINP = 10 ,
38767      &            LOUT = 6 ,
38768      &            LDAT = 9 )
38769
38770 * Lorentz-parameters of the current interaction
38771       COMMON /DTLTRA/ GACMS(2),BGCMS(2),GALAB,BGLAB,BLAB,
38772      &                UMO,PPCM,EPROJ,PPROJ
38773
38774 *
38775       IREJ = 0
38776       XQ   = 0.0D0
38777       XAQ  = 0.0D0
38778 *
38779 * sample quark flavour
38780 *
38781 *  set seasq here (the one from DTCHAI should be used in the future)
38782       SEASQ = 0.5D0
38783       IFLV  = INT(1.0D0+DT_RNDM(XQMAX)*(2.0D0+SEASQ))
38784 *
38785 * sample energy fractions of sea pair
38786 * we first sample the energy fraction of a gluon and then split the gluon
38787 *
38788 *  maximum energy fraction of the gluon forced via input
38789       XGMAXI = XQMAX+XAQMAX
38790 *  minimum energy fraction of the gluon
38791       XTHR1 = 4.0D0 /UMO**2
38792       XTHR2 = 0.54D0/UMO**1.5D0
38793       XGMIN = MAX(XTHR1,XTHR2)
38794 *  maximum energy fraction of the gluon
38795       XGMAX = 0.3D0
38796       XGMAX = MIN(XGMAXI,XGMAX)
38797       IF (XGMIN.GE.XGMAX) THEN
38798          IREJ = 1
38799          RETURN
38800       ENDIF
38801 *
38802 *  sample energy fraction of the gluon
38803       NLOOP = 0
38804     1 CONTINUE
38805       NLOOP = NLOOP+1
38806       IF (NLOOP.GE.50) THEN
38807          IREJ = 1
38808          RETURN
38809       ENDIF
38810       XGLUON = DT_SAMSQX(XGMIN,XGMAX)
38811       EGLUON = XGLUON*UMO/2.0D0
38812 *
38813 *  split gluon into q-aq pair (we follow PHOJET's subroutine PHO_GLU2QU)
38814       ZMIN = MIN(0.1D0,0.5D0/EGLUON)
38815       ZMAX = 1.0D0-ZMIN
38816       RZ   = DT_RNDM(ZMAX)
38817       XHLP = ((1.0D0-RZ)*ZMIN**3+RZ*ZMAX**3)**0.33333
38818       RQ   = DT_RNDM(ZMAX)
38819       IF (RQ.LT.0.5D0) THEN
38820          XQ  = XGLUON*XHLP
38821          XAQ = XGLUON-XQ
38822       ELSE
38823          XAQ = XGLUON*XHLP
38824          XQ  = XGLUON-XAQ
38825       ENDIF
38826       IF ((XQ.GT.XQMAX).OR.(XAQ.GT.XAQMAX)) GOTO 1
38827
38828       RETURN
38829       END